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

formatting etc

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

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

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

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

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

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

@ -3,7 +3,7 @@
(struct cgi-error ())
(struct incomplete-%-suffix (chars))
(struct invalid-%-suffix (char))
;; -- cgi methods --
get-bindings
get-bindings/post
@ -15,9 +15,8 @@
extract-bindings
extract-binding/single
get-cgi-method
;; -- general HTML utilities --
string->html
generate-link-text
)

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

@ -5,238 +5,235 @@
(import)
(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)
;; -- gives the suffix which is invalid, not including the `%'
;; chars : list (char)
;; -- 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
;; -- an invalid character in a hex string
;; char : char
;; -- 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
;; is as follows:
;; spaces are turned into "+"es and lots of things are turned into %XX,
;; where XX are hex digits, eg, %E7 for ~. The output is a regular
;; Scheme string with all the characters converted back.
;; -- The input is the characters post-processed as per Web specs, which
;; is as follows:
;; spaces are turned into "+"es and lots of things are turned into %XX, where
;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
;; with all the characters converted back.
(define (query-chars->string chars)
(list->string
(let loop ([chars chars])
(if (null? chars) null
(let ([first (car chars)]
[rest (cdr chars)])
(let-values ([(this rest)
(cond
[(char=? first #\+)
(values #\space rest)]
[(char=? first #\%)
(if (and (pair? rest)
(pair? (cdr rest)))
(values
(integer->char
(or (string->number
(string
(car rest) (cadr rest))
16)
(raise (make-invalid-%-suffix
(if (string->number
(string (car rest))
16)
(cadr rest)
(car rest))))))
(cddr rest))
(raise
(make-incomplete-%-suffix rest)))]
[else
(values first rest)])])
(cons this (loop rest))))))))
(define (query-chars->string chars)
(list->string
(let loop ([chars chars])
(if (null? chars) null
(let ([first (car chars)]
[rest (cdr chars)])
(let-values ([(this rest)
(cond
[(char=? first #\+)
(values #\space rest)]
[(char=? first #\%)
(if (and (pair? rest) (pair? (cdr rest)))
(values
(integer->char
(or (string->number
(string (car rest) (cadr rest))
16)
(raise (make-invalid-%-suffix
(if (string->number
(string (car rest))
16)
(cadr rest)
(car rest))))))
(cddr rest))
(raise (make-incomplete-%-suffix rest)))]
[else
(values first rest)])])
(cons this (loop rest))))))))
;; string->html : string -> string
;; -- the input is raw text, the output is HTML appropriately quoted
;; string->html : string -> string
;; -- the input is raw text, the output is HTML appropriately quoted
(define (string->html s)
(apply string-append (map (lambda (c)
(case c
[(#\<) "&lt;"]
[(#\>) "&gt;"]
[(#\&) "&amp;"]
[else (string c)]))
(string->list s))))
(define (string->html s)
(apply string-append
(map (lambda (c)
(case c
[(#\<) "&lt;"]
[(#\>) "&gt;"]
[(#\&) "&amp;"]
[else (string c)]))
(string->list s))))
(define default-text-color "#000000")
(define default-bg-color "#ffffff")
(define default-link-color "#cc2200")
(define default-vlink-color "#882200")
(define default-alink-color "#444444")
(define default-text-color "#000000")
(define default-bg-color "#ffffff")
(define default-link-color "#cc2200")
(define default-vlink-color "#882200")
(define default-alink-color "#444444")
;; generate-html-output :
;; html-string x list (html-string) x ... -> ()
;; generate-html-output :
;; html-string x list (html-string) x ... -> ()
(define generate-html-output
(opt-lambda (title body-lines
[text-color default-text-color]
[bg-color default-bg-color]
[link-color default-link-color]
[vlink-color default-vlink-color]
[alink-color default-alink-color])
(let ([sa string-append])
(for-each
(lambda (l) (display l) (newline))
`("Content-type: text/html"
""
"<html>"
"<!-- The form was processed, and this document was generated,"
" using the CGI utilities for MzScheme. For more information"
" on MzScheme, see"
" http://www.plt-scheme.org/software/mzscheme/"
" and for the CGI utilities, contact"
" (sk@cs.brown.edu). -->"
"<head>"
,(sa "<title>" title "</title>")
"</head>"
""
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
,(sa " link=\"" link-color "\"")
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
""
,@body-lines
""
"</body>"
"</html>")))))
(define generate-html-output
(opt-lambda (title body-lines
[text-color default-text-color]
[bg-color default-bg-color]
[link-color default-link-color]
[vlink-color default-vlink-color]
[alink-color default-alink-color])
(let ([sa string-append])
(for-each
(lambda (l) (display l) (newline))
`("Content-type: text/html"
""
"<html>"
"<!-- The form was processed, and this document was generated,"
" using the CGI utilities for MzScheme. For more information"
" on MzScheme, see"
" http://www.plt-scheme.org/software/mzscheme/"
" and for the CGI utilities, contact"
" (sk@cs.brown.edu). -->"
"<head>"
,(sa "<title>" title "</title>")
"</head>"
""
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
,(sa " link=\"" link-color "\"")
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
""
,@body-lines
""
"</body>"
"</html>")))))
;; output-http-headers : -> void
(define (output-http-headers)
(printf "Content-type: text/html\r\n\r\n"))
;; output-http-headers : -> void
(define (output-http-headers)
(printf "Content-type: text/html\r\n\r\n"))
;; read-until-char : iport x char -> list (char) x bool
;; -- operates on the default input port; the second value indicates
;; whether reading stopped because an EOF was hit (as opposed to the
;; delimiter being seen); the delimiter is not part of the result
(define (read-until-char ip delimiter)
(let loop ([chars '()])
(let ([c (read-char ip)])
(cond [(eof-object? c) (values (reverse chars) #t)]
[(char=? c delimiter) (values (reverse chars) #f)]
[else (loop (cons c chars))]))))
;; read-until-char : iport x char -> list (char) x bool
;; -- operates on the default input port; the second value indicates whether
;; reading stopped because an EOF was hit (as opposed to the delimiter being
;; seen); the delimiter is not part of the result
(define (read-until-char ip delimiter)
(let loop ([chars '()])
(let ([c (read-char ip)])
(cond [(eof-object? c) (values (reverse chars) #t)]
[(char=? c delimiter) (values (reverse chars) #f)]
[else (loop (cons c chars))]))))
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
;; -- If the first value is false, so is the second, and the third is
;; true, indicating EOF was reached without any input seen. Otherwise,
;; the first and second values contain strings and the third is either
;; true or false depending on whether the EOF has been reached. The
;; strings are processed to remove the CGI spec "escape"s.
;; This code is _slightly_ lax: it allows an input to end in `&'. It's
;; not clear this is legal by the CGI spec, which suggests that the last
;; value binding must end in an EOF. It doesn't look like this matters.
;; It would also introduce needless modality and reduce flexibility.
(define (read-name+value ip)
(let-values ([(name eof?) (read-until-char ip #\=)])
(cond [(and eof? (null? name)) (values #f #f #t)]
[eof?
(generate-error-output
(list "Server generated malformed input for POST method:"
(string-append
"No binding for `" (list->string name) "' field.")))]
[else (let-values ([(value eof?) (read-until-char ip #\&)])
(values (string->symbol (query-chars->string name))
(query-chars->string value)
eof?))])))
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
;; -- If the first value is false, so is the second, and the third is true,
;; indicating EOF was reached without any input seen. Otherwise, the first
;; and second values contain strings and the third is either true or false
;; depending on whether the EOF has been reached. The strings are processed
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows
;; an input to end in `&'. It's not clear this is legal by the CGI spec,
;; which suggests that the last value binding must end in an EOF. It doesn't
;; look like this matters. It would also introduce needless modality and
;; reduce flexibility.
(define (read-name+value ip)
(let-values ([(name eof?) (read-until-char ip #\=)])
(cond [(and eof? (null? name)) (values #f #f #t)]
[eof?
(generate-error-output
(list "Server generated malformed input for POST method:"
(string-append
"No binding for `" (list->string name) "' field.")))]
[else (let-values ([(value eof?) (read-until-char ip #\&)])
(values (string->symbol (query-chars->string name))
(query-chars->string value)
eof?))])))
;; get-bindings/post : () -> bindings
(define (get-bindings/post)
(let-values ([(name value eof?) (read-name+value (current-input-port))])
;; get-bindings/post : () -> bindings
(define (get-bindings/post)
(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]
[(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
(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]
[(and eof? name) (list (cons name value))]
[else (cons (cons name value) (loop))])))))
;; get-bindings : () -> bindings
(define (get-bindings)
(if (string=? (get-cgi-method) "POST")
(get-bindings/post)
(get-bindings/get)))
;; get-bindings : () -> bindings
(define (get-bindings)
(if (string=? (get-cgi-method) "POST")
(get-bindings/post)
(get-bindings/get)))
;; generate-error-output : list (html-string) -> <exit>
(define (generate-error-output error-message-lines)
(generate-html-output "Internal Error" error-message-lines)
(exit))
;; generate-error-output : list (html-string) -> <exit>
(define (generate-error-output error-message-lines)
(generate-html-output "Internal Error" error-message-lines)
(exit))
;; bindings-as-html : bindings -> list (html-string)
;; -- formats name-value bindings as HTML appropriate for displaying
(define (bindings-as-html bindings)
`("<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)
;; -- formats name-value bindings as HTML appropriate for displaying
(define (bindings-as-html bindings)
`("<code>"
,@(map (lambda (bind)
(string-append (symbol->string (car bind))
"&nbsp;--&gt;&nbsp;"
(cdr bind)
"<br>"))
bindings)
"</code>"))
;; extract-bindings : (string + symbol) x bindings -> list (string)
;; -- Extracts the bindings associated with a given name. The semantics of
;; forms states that a CHECKBOX may use the same NAME field multiple times.
;; Hence, a list of strings is returned. Note that the result may be the
;; empty list.
(define (extract-bindings field-name bindings)
(let ([field-name (if (symbol? field-name)
field-name (string->symbol field-name))])
(let loop ([found null] [bindings bindings])
(if (null? bindings)
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)
;; -- Extracts the bindings associated with a given name. The semantics
;; of forms states that a CHECKBOX may use the same NAME field multiple
;; times. Hence, a list of strings is returned. Note that the result
;; may be the empty list.
(define (extract-bindings field-name bindings)
(let ([field-name (if (symbol? field-name)
field-name (string->symbol field-name))])
(let loop ([found null] [bindings bindings])
(if (null? bindings)
found
(if (equal? field-name (caar bindings))
(loop (cons (cdar bindings) found) (cdr bindings))
(loop found (cdr bindings)))))))
;; extract-binding/single : (string + symbol) x bindings -> string
;; -- used in cases where only one binding is supposed to occur
(define (extract-binding/single field-name bindings)
(let* ([field-name (if (symbol? field-name)
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)))])))
;; extract-binding/single : (string + symbol) x bindings -> string
;; -- used in cases where only one binding is supposed to occur
(define (extract-binding/single field-name bindings)
(let* ([field-name (if (symbol? field-name)
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
;; -- string is either GET or POST (though future extension is possible)
(define (get-cgi-method)
(getenv "REQUEST_METHOD"))
;; get-cgi-method : () -> string
;; -- string is either GET or POST (though future extension is possible)
(define (get-cgi-method)
(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>"))
)
;; 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
(require (lib "unit.ss")
"cgi-sig.ss"
"cgi-unit.ss")
(require (lib "unit.ss") "cgi-sig.ss" "cgi-unit.ss")
(define-values/invoke-unit/infer cgi@)

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

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

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

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

6
collects/net/cookie.ss
View File

@ -1,8 +1,6 @@
(module cookie mzscheme
(require (lib "unit.ss")
"cookie-sig.ss"
"cookie-unit.ss")
(require (lib "unit.ss") "cookie-sig.ss" "cookie-unit.ss")
(provide-signature-elements cookie^)
(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-mail-exchanger
dns-find-nameserver)

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

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

4
collects/net/dns.ss
View File

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

16
collects/net/doc.txt
View File

@ -31,7 +31,7 @@ TYPES ----------------------------------------------------------------
_url struct_
(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-host : url -> (union false/c string?)
> url-port : url -> (union false/c number?)
@ -497,12 +497,12 @@ EXCEPTIONS -----------------------------------------------------------
PROCEDURES -----------------------------------------------------------
> (smtp-send-message server-string from-string to-list-of-strings header
message-list-of-strings/bytes
[#:port-no k]
[#:auth-user user-string-or-#f]
[#:auth-passwd pw-string-or-#f]
[#:tcp-connect proc]
[port-no]) -> void
message-list-of-strings/bytes
[#:port-no k]
[#:auth-user user-string-or-#f]
[#:auth-passwd pw-string-or-#f]
[#:tcp-connect proc]
[port-no]) -> void
The first argument is the IP address of the SMTP server. The
`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
select the separator. The default is 'semi.
> (form-urlencoded->alist string [separator-mode-sym])
: String -> alist

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

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

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

@ -1,215 +1,217 @@
(module ftp-unit (lib "a-unit.ss")
;; Version 0.2
;; Version 0.1a
;; Micah Flatt
;; Version 0.1a
;; Micah Flatt
;; 06-06-2002
(require (lib "date.ss")
(lib "file.ss")
(lib "port.ss")
"ftp-sig.ss")
(require (lib "date.ss") (lib "file.ss") (lib "port.ss") "ftp-sig.ss")
(import)
(export ftp^)
;; opqaue record to represent an FTP connection:
(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] ")
;; opqaue record to represent an FTP connection:
(define-struct tcp-connection (in out))
(define (check-expected-result line expected)
(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 tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
(define (get-month month-bytes)
(cond
[(equal? #"Jan" month-bytes) 1]
[(equal? #"Feb" month-bytes) 2]
[(equal? #"Mar" month-bytes) 3]
[(equal? #"Apr" month-bytes) 4]
[(equal? #"May" month-bytes) 5]
[(equal? #"Jun" month-bytes) 6]
[(equal? #"Jul" month-bytes) 7]
[(equal? #"Aug" month-bytes) 8]
[(equal? #"Sep" month-bytes) 9]
[(equal? #"Oct" month-bytes) 10]
[(equal? #"Nov" month-bytes) 11]
[(equal? #"Dec" month-bytes) 12]))
(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
(define re:response-end #rx#"^[0-9][0-9][0-9] ")
(define (bytes->number bytes)
(string->number (bytes->string/latin-1 bytes)))
(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
(define (check-expected-result line expected)
(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))))
(define (ftp-make-file-seconds ftp-date-str)
(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
(if (not (list-ref date-list 4))
(find-seconds 0
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 re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
;; 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 (establish-data-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "PASV~n")
(let ([response (ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"227"
(lambda (s ignore) s) ;; should be the only response
(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 (get-month month-bytes)
(cond [(assoc month-bytes
'((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
(#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10)
(#"Nov" 11) (#"Dec" 12)))
=> cadr]
[else (error 'get-month "bad month: ~s" month-bytes)]))
;; Used where version 0.1a printed responses:
(define (print-msg s ignore)
;; (printf "~a~n" s)
(void))
(define (bytes->number bytes)
(string->number (bytes->string/latin-1 bytes)))
(define (ftp-establish-connection* in out username password)
(ftp-check-response in out #"220" print-msg (void))
(display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
(let ([no-password? (ftp-check-response in out (list #"331" #"230")
(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 re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
(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 (ftp-make-file-seconds ftp-date-str)
(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
(if (not (list-ref date-list 4))
(find-seconds 0
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)
(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 re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(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 (establish-data-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "PASV\n")
(let ([response (ftp-check-response
(tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"227"
(lambda (s ignore) s) ; should be the only response
(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)
(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-establish-connection* in out username password)
(ftp-check-response in out #"220" print-msg (void))
(display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
(let ([no-password? (ftp-check-response
in out (list #"331" #"230")
(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-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)))
(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)))
;; (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
(require (lib "unit.ss")
"ftp-sig.ss"
"ftp-unit.ss")
(require (lib "unit.ss") "ftp-sig.ss" "ftp-unit.ss")
(define-values/invoke-unit/infer ftp@)

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

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

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

@ -1,400 +1,348 @@
(module head-unit (lib "a-unit.ss")
(require (lib "date.ss")
(lib "string.ss")
"head-sig.ss")
(require (lib "date.ss") (lib "string.ss") "head-sig.ss")
(import)
(export head^)
;; NB: I've done a copied-code adaptation of a number of these definitions into
;; "bytes-compatible" versions. Finishing the rest will require some kind of interface
;; decision---that is, when you don't supply a header, should the resulting operation
;; be string-centric or bytes-centric? Easiest just to stop here.
;; -- JBC 2006-07-31
;; NB: I've done a copied-code adaptation of a number of these definitions
;; into "bytes-compatible" versions. Finishing the rest will require some
;; kind of interface decision---that is, when you don't supply a header,
;; should the resulting operation be string-centric or bytes-centric?
;; Easiest just to stop here.
;; -- JBC 2006-07-31
(define CRLF (string #\return #\newline))
(define CRLF/bytes #"\r\n")
(define empty-header CRLF)
(define empty-header/bytes CRLF/bytes)
(define CRLF (string #\return #\newline))
(define CRLF/bytes #"\r\n")
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
(define re: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 empty-header CRLF)
(define empty-header/bytes CRLF/bytes)
(define (make-field-start-regexp/bytes field)
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
(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:
(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)
(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$"
s
(subbytes header start (bytes-length header))
""))))))
;; 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:
;; 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$"
s
""))))))))
(substring header start (string-length header))
""))))))
;; malformed header:
null))))))
(define (replace-field field data header)
(if (bytes? header)
(let ([m (regexp-match-positions
(make-field-start-regexp/bytes field)
header)])
;; 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)
(if (null? l)
""
(format "~a~a"
(car l)
(apply string-append
(map (lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas)
(splice datas "\r\n\t"))
;; Extracting Addresses ;;
(define blank "[ \t\n\r\v]")
(define nonblank "[^ \t\n\r\v]")
(define re:all-blank (regexp (format "^~a*$" blank)))
(define re:quoted (regexp "\"[^\"]*\""))
(define re:parened (regexp "[(][^)]*[)]"))
(define re:comma (regexp ","))
(define re:comma-separated (regexp "([^,]*),(.*)"))
(define (extract-addresses s form)
(unless (memq form '(name address full all))
(raise-type-error 'extract-addresses
"form: 'name, 'address, 'full, or 'all"
form))
(if (or (not s) (regexp-match re:all-blank s))
null
(let loop ([prefix ""][s s])
;; Which comes first - a quote or a comma?
(let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2))
mq1
mq2)
(or mq1 mq2))]
[mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
;; Quote contains a comma
(loop (string-append
prefix
(substring s 0 (cdar mq)))
(substring s (cdar mq) (string-length s)))
;; Normal comma parsing:
(let ([m (regexp-match re:comma-separated s)])
(if m
(let ([pre (subbytes header
0
(caaddr m))]
[s (subbytes header
(cdaddr m)
(bytes-length header))])
(let* ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
[rest (if m
(subbytes s (+ 2 (caar m))
(bytes-length s))
empty-header/bytes)])
(bytes-append pre
(if data
(insert-field field data rest)
rest))))
(if data
(insert-field field data header)
header)))
;; 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)))))
(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 (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 (select-result form name addr full)
(case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(define (data-lines->data datas)
(splice datas "\r\n\t"))
(define (one-result form s)
(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 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-one-name orig form)
(let loop ([s orig][form form])
(cond
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
[(regexp-match re:parened-name s)
=> (lambda (m)
(let ([name (caddr m)]
[all (loop (cadr m) 'all)])
(select-result
form
(if (string=? (car all) (cadr all)) name (car all))
(cadr all)
(format "~a (~a)" (caddr all) name))))]
[(regexp-match re:quoted-name s)
=> (lambda (m)
(let ([name (cadr m)]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(regexp-match re:simple-name s)
=> (lambda (m)
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(or (regexp-match "<" s) (regexp-match ">" s))
(one-result form (extract-angle-addr s orig))]
[else (one-result form (extract-simple-addr s orig))])))
(define (extract-addresses s form)
(unless (memq form '(name address full all))
(raise-type-error 'extract-addresses
"form: 'name, 'address, 'full, or 'all"
form))
(if (or (not s) (regexp-match re:all-blank s))
null
(let loop ([prefix ""][s s])
;; Which comes first - a quote or a comma?
(let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2))
mq1
mq2)
(or mq1 mq2))]
[mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
;; Quote contains a comma
(loop (string-append
prefix
(substring s 0 (cdar mq)))
(substring s (cdar mq) (string-length s)))
;; Normal comma parsing:
(let ([m (regexp-match re:comma-separated s)])
(if m
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
[rest (extract-addresses (caddr m) form)])
(cons n rest))
(let ([n (extract-one-name (string-append prefix s) form)])
(list n)))))))))
(define (select-result form name addr full)
(case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(define (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 (one-result form s)
(select-result form s s s))
(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 re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
(define re:double-less (regexp "<.*<"))
(define re:double-greater (regexp ">.*>"))
(define re:bad-chars (regexp "[,\"()<>]"))
(define re:tail-blanks (regexp (format "~a+$" blank)))
(define re:head-blanks (regexp (format "^~a+" blank)))
(define (extract-one-name orig form)
(let loop ([s orig][form form])
(cond
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
[(regexp-match re:parened-name s)
=> (lambda (m)
(let ([name (caddr m)]
[all (loop (cadr m) 'all)])
(select-result form
(if (string=? (car all) (cadr all))
name
(car all))
(cadr all)
(format "~a (~a)" (caddr all) name))))]
[(regexp-match re:quoted-name s)
=> (lambda (m)
(let ([name (cadr m)]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(regexp-match re:simple-name s)
=> (lambda (m)
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(or (regexp-match "<" s) (regexp-match ">" s))
(one-result form (extract-angle-addr s orig))]
[else
(one-result form (extract-simple-addr s orig))])))
(define (extract-angle-addr s orig)
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
(error 'extract-address "too many angle brackets: ~a" s)
(let ([m (regexp-match re:normal-name s)])
(if m
(extract-simple-addr (cadr m) orig)
(error 'extract-address "cannot parse address: ~a" orig)))))
(define (extract-simple-addr s orig)
(cond
[(regexp-match re:bad-chars s)
(error 'extract-address "cannot parse address: ~a" orig)]
[else
;; final whitespace strip
(regexp-replace
re:tail-blanks
(regexp-replace re:head-blanks s "")
"")]))
(define (assemble-address-field addresses)
(if (null? addresses)
""
(let loop ([addresses (cdr addresses)]
[s (car addresses)]
[len (string-length (car addresses))])
(if (null? addresses)
s
(let* ([addr (car addresses)]
[alen (string-length addr)])
(if (<= 72 (+ len alen))
(loop (cdr addresses)
(format "~a,~a~a~a~a"
s #\return #\linefeed
#\tab addr)
alen)
(loop (cdr addresses)
(format "~a, ~a" s addr)
(+ len alen 2)))))))))
(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
(require (lib "unit.ss")
"head-sig.ss"
"head-unit.ss")
(require (lib "unit.ss") "head-sig.ss" "head-unit.ss")
(define-values/invoke-unit/infer head@)

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

@ -1,7 +1,7 @@
(module imap-sig (lib "a-signature.ss")
imap-port-number
imap-connection?
imap-connect imap-connect*
imap-disconnect
imap-force-disconnect
@ -10,7 +10,7 @@
imap-noop
imap-status
imap-poll
imap-new?
imap-messages
imap-recent
@ -18,21 +18,20 @@
imap-uidvalidity
imap-unseen
imap-reset-new!
imap-get-expunges
imap-pending-expunges?
imap-get-updates
imap-pending-updates?
imap-get-messages
imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag
imap-expunge
imap-mailbox-exists?
imap-create-mailbox
imap-list-child-mailboxes
imap-mailbox-flags
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
(require (lib "unit.ss")
(lib "contract.ss")
"imap-sig.ss"
"imap-unit.ss")
(require (lib "unit.ss") (lib "contract.ss") "imap-sig.ss" "imap-unit.ss")
(define-values/invoke-unit/infer imap@)
(provide/contract
[imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
[imap-list-child-mailboxes
@ -14,7 +11,7 @@
(imap-connection? (or/c false/c bytes?) (or/c false/c bytes?)
. -> .
(listof (list/c (listof symbol?) bytes?))))])
(provide
imap-connection?
imap-connect imap-connect*
@ -25,7 +22,7 @@
imap-noop
imap-poll
imap-status
imap-port-number ; a parameter
imap-new?
@ -35,18 +32,18 @@
imap-uidvalidity
imap-unseen
imap-reset-new!
imap-get-expunges
imap-pending-expunges?
imap-get-updates
imap-pending-updates?
imap-get-messages
imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag
imap-expunge
imap-mailbox-exists?
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-subtype () -setters -constructor)
(struct empty-disposition-type () -setters -constructor)
;; -- basic mime structures --
(struct message (version entity fields))
(struct entity
@ -20,7 +20,7 @@
(type filename creation
modification read
size params))
;; -- mime methods --
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
;;; 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.
@ -40,22 +40,22 @@
;; that has character c
(define string-index
(lambda (s c)
(let ((n (string-length s)))
(let loop ((i 0))
(cond ((>= i n) #f)
((char=? (string-ref s i) c) i)
(else (loop (+ i 1))))))))
(let ([n (string-length s)])
(let loop ([i 0])
(cond [(>= i n) #f]
[(char=? (string-ref s i) c) i]
[else (loop (+ i 1))])))))
;; string-tokenizer breaks string s into substrings separated by character c
(define string-tokenizer
(lambda (c s)
(let loop ((s s))
(if (string=? s "") '()
(let ((i (string-index s c)))
(if i (cons (substring s 0 i)
(loop (substring s (+ i 1)
(string-length s))))
(list s)))))))
(let loop ([s s])
(if (string=? s "") '()
(let ([i (string-index s c)])
(if i (cons (substring s 0 i)
(loop (substring s (+ i 1)
(string-length s))))
(list s)))))))
;; Trim all spaces, except those in quoted strings.
(define re:quote-start (regexp "\""))
@ -65,30 +65,30 @@
;; Break out alternate quoted and unquoted parts.
;; Initial and final string are unquoted.
(let-values ([(unquoted quoted)
(let loop ([str str][unquoted null][quoted null])
(let ([m (regexp-match-positions re:quote-start str)])
(if m
(let ([prefix (substring str 0 (caar m))]
[rest (substring str (add1 (caar m)) (string-length str))])
;; Find closing quote
(let ([m (regexp-match-positions re:quote-start rest)])
(if m
(let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))])
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
;; No closing quote!
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
(values (reverse! (cons str unquoted)) (reverse! quoted)))))])
;; Put the pieces back together, stripping spaces for unquoted parts:
(apply
string-append
(let loop ([unquoted unquoted][quoted quoted])
(let ([clean (regexp-replace* re:space (car unquoted) "")])
(if (null? quoted)
(list clean)
(list* clean
(car quoted)
(loop (cdr unquoted) (cdr quoted))))))))))
(let loop ([str str] [unquoted null] [quoted null])
(let ([m (regexp-match-positions re:quote-start str)])
(if m
(let ([prefix (substring str 0 (caar m))]
[rest (substring str (add1 (caar m)) (string-length str))])
;; Find closing quote
(let ([m (regexp-match-positions re:quote-start rest)])
(if m
(let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))])
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
;; No closing quote!
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
(values (reverse! (cons str unquoted)) (reverse! quoted)))))])
;; Put the pieces back together, stripping spaces for unquoted parts:
(apply
string-append
(let loop ([unquoted unquoted][quoted quoted])
(let ([clean (regexp-replace* re:space (car unquoted) "")])
(if (null? quoted)
(list clean)
(list* clean
(car quoted)
(loop (cdr unquoted) (cdr quoted))))))))))
;; Only trims left and right spaces:
(define trim-spaces
@ -108,39 +108,41 @@
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define trim-comments
(lambda (str)
(let* ((positions (regexp-match-positions re:comments str)))
(if positions
(string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str)))
str))))
(let ([positions (regexp-match-positions re:comments str)])
(if positions
(string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str)))
str))))
(define lowercase
(lambda (str)
(let loop ((out "") (rest str) (size (string-length str)))
(cond ((zero? size) out)
(else
(loop (string-append out (string
(char-downcase
(string-ref rest 0))))
(substring rest 1 size)
(sub1 size)))))))
(let loop ([out ""] [rest str] [size (string-length str)])
(cond [(zero? size) out]
[else
(loop (string-append out (string
(char-downcase
(string-ref rest 0))))
(substring rest 1 size)
(sub1 size))]))))
(define warning void)
#|
(define warning
void
#;
(lambda (msg . args)
(fprintf (current-error-port)
(apply format (cons msg args)))
(newline (current-error-port))))
|#
(apply format (cons msg args)))
(newline (current-error-port)))
)
;; Copies its input `in' to its ouput port if given, it uses
;; current-output-port if out is not provided.
(define cat
(opt-lambda (in (out (current-output-port)))
(let loop ((ln (read-line in)))
(unless (eof-object? ln)
(fprintf out "~a~n" ln)
(loop (read-line in))))))
(let loop ([ln (read-line in)])
(unless (eof-object? ln)
(fprintf out "~a\n" ln)
(loop (read-line in))))))
)
;;; mime-util.ss ends here

12
collects/net/mime.ss
View File

@ -1,8 +1,8 @@
;;;
;;; <mime.ss> ---- MIME support
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Wish Computing.
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Wish Computing.
;;;
;;; This file is part of mime
@ -34,8 +34,8 @@
"qp.ss"
"base64-sig.ss"
"base64.ss"
"head-sig.ss"
"head.ss")
"head-sig.ss"
"head.ss")
(define-unit-from-context base64@ base64^)
(define-unit-from-context qp@ qp^)
@ -43,9 +43,9 @@
(define-compound-unit/infer mime@2 (import) (export mime^)
(link base64@ qp@ head@ mime@))
(define-values/invoke-unit/infer mime@2)
(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
newnews-since generic-message-command
make-desired-header extract-desired-headers
(struct nntp ())
(struct unexpected-response (code text))
(struct bad-status-line (line))
@ -16,5 +16,3 @@
(struct no-group-selected ())
(struct article-not-found (article))
(struct authentication-rejected ()))

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

@ -1,337 +1,331 @@
(module nntp-unit (lib "a-unit.ss")
(require (lib "etc.ss")
"nntp-sig.ss")
(require (lib "etc.ss") "nntp-sig.ss")
(import)
(export nntp^)
;; sender : oport
;; receiver : iport
;; server : string
;; port : number
;; sender : oport
;; receiver : iport
;; server : string
;; port : number
(define-struct communicator (sender receiver server port))
(define-struct communicator (sender receiver server port))
;; code : number
;; text : string
;; line : string
;; communicator : communicator
;; group : string
;; article : number
;; code : number
;; text : string
;; line : string
;; communicator : communicator
;; group : string
;; article : number
(define-struct (nntp exn) ())
(define-struct (unexpected-response nntp) (code text))
(define-struct (bad-status-line nntp) (line))
(define-struct (premature-close nntp) (communicator))
(define-struct (bad-newsgroup-line nntp) (line))
(define-struct (non-existent-group nntp) (group))
(define-struct (article-not-in-group nntp) (article))
(define-struct (no-group-selected nntp) ())
(define-struct (article-not-found nntp) (article))
(define-struct (authentication-rejected nntp) ())
(define-struct (nntp exn) ())
(define-struct (unexpected-response nntp) (code text))
(define-struct (bad-status-line nntp) (line))
(define-struct (premature-close nntp) (communicator))
(define-struct (bad-newsgroup-line nntp) (line))
(define-struct (non-existent-group nntp) (group))
(define-struct (article-not-in-group nntp) (article))
(define-struct (no-group-selected nntp) ())
(define-struct (article-not-found nntp) (article))
(define-struct (authentication-rejected nntp) ())
;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> ()
;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> ()
;; - throws an exception
;; - throws an exception
(define signal-error
(lambda (constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(string->immutable-string (apply format format-string args))
(current-continuation-marks)
exn-args)))))
(define signal-error
(lambda (constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(string->immutable-string (apply format format-string args))
(current-continuation-marks)
exn-args)))))
;; default-nntpd-port-number :
;; number
;; default-nntpd-port-number :
;; number
(define default-nntpd-port-number 119)
(define default-nntpd-port-number 119)
;; connect-to-server*:
;; 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
;; connect-to-server*:
;; input-port output-port -> communicator
(define connect-to-server
(opt-lambda (server-name (port-number default-nntpd-port-number))
(let-values (((receiver sender)
(tcp-connect server-name port-number)))
(connect-to-server* receiver sender server-name port-number))))
(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
[(200 201) communicator]
[else ((signal-error make-unexpected-response
"unexpected connection response: ~s ~s"
code response)
code response)])))]))
;; close-communicator :
;; communicator -> ()
;; connect-to-server :
;; string [x number] -> commnicator
(define close-communicator
(lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
(define connect-to-server
(opt-lambda (server-name (port-number default-nntpd-port-number))
(let-values ([(receiver sender)
(tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; disconnect-from-server :
;; communicator -> ()
;; close-communicator :
;; communicator -> ()
(define disconnect-from-server
(lambda (communicator)
(send-to-server communicator "QUIT")
(let-values (((code response)
(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))))))
(define close-communicator
(lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
;; authenticate-user :
;; communicator x user-name x password -> ()
;; the password is not used if the server does not ask for it.
;; disconnect-from-server :
;; communicator -> ()
(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)))
(define disconnect-from-server
(lambda (communicator)
(send-to-server communicator "QUIT")
(let-values ([(code response)
(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 :
;; 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
((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)))
(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
[(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 group opening response: ~s" code)
code rest-of-line))))))
"unexpected message access response: ~s" code)
code response)]))))))
;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string)
;; head-of-message :
;; 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
((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))))))))
(define head-of-message
(generic-message-command "HEAD" 221))
;; head-of-message :
;; communicator x (number U string) -> list (string)
;; body-of-message :
;; communicator x (number U string) -> list (string)
(define head-of-message
(generic-message-command "HEAD" 221))
(define body-of-message
(generic-message-command "BODY" 222))
;; body-of-message :
;; communicator x (number U string) -> list (string)
;; newnews-since :
;; communicator x (number U string) -> list (string)
(define body-of-message
(generic-message-command "BODY" 222))
(define newnews-since
(generic-message-command "NEWNEWS" 230))
;; newnews-since :
;; communicator x (number U string) -> list (string)
(define newnews-since
(generic-message-command "NEWNEWS" 230))
;; make-desired-header :
;; string -> desired
;; make-desired-header :
;; string -> desired
(define make-desired-header
(lambda (raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
[(char-lower-case? c)
(list #\[ (char-upcase c) c #\])]
[(char-upper-case? c)
(list #\[ c (char-downcase c) #\])]
[else
(list c)]))
(string->list raw-header))))
":"))))
(define make-desired-header
(lambda (raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
((char-lower-case? c)
(list #\[ (char-upcase c) c #\]))
((char-upper-case? c)
(list #\[ c (char-downcase c) #\]))
(else
(list c))))
(string->list raw-header))))
":"))))
;; extract-desired-headers :
;; list (string) x list (desired) -> list (string)
(define extract-desired-headers
(lambda (headers desireds)
(let loop ((headers headers))
(if (null? headers) null
(let ((first (car headers))
(rest (cdr headers)))
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest))))))))
;; 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))))))))

4
collects/net/nntp.ss
View File

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

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

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

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

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

5
collects/net/pop3.ss
View File

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

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

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

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

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

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

@ -1,8 +1,8 @@
;;;
;;; <qp-unit.ss> ---- Quoted Printable Implementation
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
;;;
;;; This file was part of mime-plt.
@ -31,143 +31,143 @@
(import)
(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)
(vector-ref hex-values i))
;; 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))
(define hex-bytes->byte
(lambda (b1 b2)
(+ (* 16 (vector-ref hex-values b1))
(vector-ref hex-values b2))))
;; 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))))
(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))]))))))
;; 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))))
;; 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)))))
(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)
(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

10
collects/net/qp.ss
View File

@ -1,8 +1,8 @@
;;;
;;; <qp.ss> ---- Quoted Printable Encoding/Decoding
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
;;;
;;; This file is part of mime-plt.
@ -26,12 +26,10 @@
;; Commentary:
(module qp mzscheme
(require (lib "unit.ss")
"qp-sig.ss"
"qp-unit.ss")
(require (lib "unit.ss") "qp-sig.ss" "qp-unit.ss")
(define-values/invoke-unit/infer qp@)
(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
(struct no-mail-recipients ()))

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

@ -1,119 +1,118 @@
(module sendmail-unit (lib "a-unit.ss")
(require (lib "process.ss")
"sendmail-sig.ss")
(require (lib "process.ss") "sendmail-sig.ss")
(import)
(export sendmail^)
(define-struct (no-mail-recipients exn) ())
(define-struct (no-mail-recipients exn) ())
(define sendmail-search-path
'("/usr/lib" "/usr/sbin"))
(define sendmail-search-path
'("/usr/lib" "/usr/sbin"))
(define sendmail-program-file
(if (or (eq? (system-type) 'unix)
(eq? (system-type) 'macosx))
(let loop ((paths sendmail-search-path))
(if (null? paths)
(raise (make-exn:fail:unsupported
"unable to find sendmail on this Unix variant"
(current-continuation-marks)))
(let ((p (build-path (car paths) "sendmail")))
(if (and (file-exists? p)
(memq 'execute (file-or-directory-permissions p)))
p
(loop (cdr paths))))))
(raise (make-exn:fail:unsupported
"sendmail only available under Unix"
(current-continuation-marks)))))
(define sendmail-program-file
(if (or (eq? (system-type) 'unix)
(eq? (system-type) 'macosx))
(let loop ([paths sendmail-search-path])
(if (null? paths)
(raise (make-exn:fail:unsupported
"unable to find sendmail on this Unix variant"
(current-continuation-marks)))
(let ([p (build-path (car paths) "sendmail")])
(if (and (file-exists? p)
(memq 'execute (file-or-directory-permissions p)))
p
(loop (cdr paths))))))
(raise (make-exn:fail:unsupported
"sendmail only available under Unix"
(current-continuation-marks)))))
;; send-mail-message/port :
;; string x string x list (string) x list (string) x list (string)
;; [x list (string)] -> oport
;; send-mail-message/port :
;; string x string x list (string) x list (string) x list (string)
;; [x list (string)] -> oport
;; -- sender can be anything, though spoofing is not recommended.
;; The recipients must all be pure email addresses. Note that
;; everything is expected to follow RFC conventions. If any other
;; headers are specified, they are expected to be completely
;; formatted already. Clients are urged to use close-output-port on
;; the port returned by this procedure as soon as the necessary text
;; has been written, so that the sendmail process can complete.
;; -- sender can be anything, though spoofing is not recommended.
;; The recipients must all be pure email addresses. Note that
;; everything is expected to follow RFC conventions. If any other
;; headers are specified, they are expected to be completely
;; formatted already. Clients are urged to use close-output-port on
;; the port returned by this procedure as soon as the necessary text
;; has been written, so that the sendmail process can complete.
(define send-mail-message/port
(lambda (sender subject to-recipients cc-recipients bcc-recipients
. other-headers)
(when (and (null? to-recipients) (null? cc-recipients)
(null? bcc-recipients))
(raise (make-no-mail-recipients
"no mail recipients were specified"
(current-continuation-marks))))
(let ((return (apply process* sendmail-program-file "-i"
(append to-recipients cc-recipients bcc-recipients))))
(let ((reader (car return))
(writer (cadr return))
(pid (caddr return))
(error-reader (cadddr return)))
(close-input-port reader)
(close-input-port error-reader)
(fprintf writer "From: ~a~n" sender)
(letrec ((write-recipient-header
(lambda (header-string recipients)
(let ((header-space
(+ (string-length header-string) 2)))
(fprintf writer "~a: " header-string)
(let loop ((to recipients) (indent header-space))
(if (null? to)
(newline writer)
(let ((first (car to))
[rest (cdr to)])
(let ((len (string-length first)))
(if (>= (+ len indent) 80)
(begin
(fprintf writer
(if (null? rest)
"~n ~a"
"~n ~a, ")
first)
(loop (cdr to)
(+ len header-space 2)))
(begin
(fprintf writer
(if (null? rest)
"~a "
"~a, ")
first)
(loop (cdr to)
(+ len indent 2))))))))))))
(write-recipient-header "To" to-recipients)
(unless (null? cc-recipients)
(write-recipient-header "CC" cc-recipients)))
(fprintf writer "Subject: ~a~n" subject)
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org~n")
(for-each (lambda (s)
(display s writer)
(newline writer))
other-headers)
(newline writer)
writer))))
(define send-mail-message/port
(lambda (sender subject to-recipients cc-recipients bcc-recipients
. other-headers)
(when (and (null? to-recipients) (null? cc-recipients)
(null? bcc-recipients))
(raise (make-no-mail-recipients
"no mail recipients were specified"
(current-continuation-marks))))
(let ([return (apply process* sendmail-program-file "-i"
(append to-recipients cc-recipients bcc-recipients))])
(let ([reader (car return)]
[writer (cadr return)]
[pid (caddr return)]
[error-reader (cadddr return)])
(close-input-port reader)
(close-input-port error-reader)
(fprintf writer "From: ~a\n" sender)
(letrec ([write-recipient-header
(lambda (header-string recipients)
(let ([header-space
(+ (string-length header-string) 2)])
(fprintf writer "~a: " header-string)
(let loop ([to recipients] [indent header-space])
(if (null? to)
(newline writer)
(let ([first (car to)]
[rest (cdr to)])
(let ([len (string-length first)])
(if (>= (+ len indent) 80)
(begin
(fprintf writer
(if (null? rest)
"\n ~a"
"\n ~a, ")
first)
(loop (cdr to)
(+ len header-space 2)))
(begin
(fprintf writer
(if (null? rest)
"~a "
"~a, ")
first)
(loop (cdr to)
(+ len indent 2))))))))))])
(write-recipient-header "To" to-recipients)
(unless (null? cc-recipients)
(write-recipient-header "CC" cc-recipients)))
(fprintf writer "Subject: ~a\n" subject)
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
(for-each (lambda (s)
(display s writer)
(newline writer))
other-headers)
(newline writer)
writer))))
;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x
;; list (string) [x list (string)] -> ()
;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x
;; list (string) [x list (string)] -> ()
;; -- sender can be anything, though spoofing is not recommended. The
;; recipients must all be pure email addresses. The text is expected
;; to be pre-formatted. Note that everything is expected to follow
;; RFC conventions. If any other headers are specified, they are
;; expected to be completely formatted already.
;; -- sender can be anything, though spoofing is not recommended. The
;; recipients must all be pure email addresses. The text is expected
;; to be pre-formatted. Note that everything is expected to follow
;; RFC conventions. If any other headers are specified, they are
;; expected to be completely formatted already.
(define send-mail-message
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
. other-headers)
(let ((writer (apply send-mail-message/port sender subject
to-recipients cc-recipients bcc-recipients
other-headers)))
(for-each (lambda (s)
(display s writer) ; We use -i, so "." is not a problem
(newline writer))
text)
(close-output-port writer)))))
(define send-mail-message
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
. other-headers)
(let ([writer (apply send-mail-message/port sender subject
to-recipients cc-recipients bcc-recipients
other-headers)])
(for-each (lambda (s)
(display s writer) ; We use -i, so "." is not a problem
(newline writer))
text)
(close-output-port writer)))))

4
collects/net/sendmail.ss
View File

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

172
collects/net/sendurl.ss
View File

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

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

@ -3,4 +3,3 @@
smtp-send-message
smtp-send-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")
(require (lib "kw.ss")
"base64.ss"
"smtp-sig.ss")
(require (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(import)
(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)
;; (apply printf args)
(void))
(define (log . args)
;; (apply printf args)
(void))
(define (starts-with? l n)
(and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n)))))
(define (starts-with? l n)
(and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n)))))
(define (check-reply r v w)
(flush-output w)
(let ([l (read-line r (if debug-via-stdio?
'linefeed
'return-linefeed))])
(log "server: ~a~n" l)
(if (eof-object? l)
(error 'check-reply "got EOF")
(let ([n (number->string v)])
(unless (starts-with? l n)
(error 'check-reply "expected reply ~a; got: ~a" v l))
(let ([n- (string-append n "-")])
(when (starts-with? l n-)
;; Multi-line reply. Go again.
(check-reply r v w)))))))
(define (check-reply r v w)
(flush-output w)
(let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))])
(log "server: ~a\n" l)
(if (eof-object? l)
(error 'check-reply "got EOF")
(let ([n (number->string v)])
(unless (starts-with? l n)
(error 'check-reply "expected reply ~a; got: ~a" v l))
(let ([n- (string-append n "-")])
(when (starts-with? l n-)
;; Multi-line reply. Go again.
(check-reply r v w)))))))
(define (protect-line l)
;; If begins with a dot, add one more
(if (or (equal? l #"")
(equal? l "")
(and (string? l)
(not (char=? #\. (string-ref l 0))))
(and (bytes? l)
(not (= (char->integer #\.) (bytes-ref l 0)))))
l
(if (bytes? l)
(bytes-append #"." l)
(string-append "." l))))
(define (protect-line l)
;; If begins with a dot, add one more
(if (or (equal? l #"")
(equal? l "")
(and (string? l)
(not (char=? #\. (string-ref l 0))))
(and (bytes? l)
(not (= (char->integer #\.) (bytes-ref l 0)))))
l
(if (bytes? l)
(bytes-append #"." l)
(string-append "." l))))
(define smtp-sending-end-of-message
(make-parameter void
(lambda (f)
(unless (and (procedure? f)
(procedure-arity-includes? f 0))
(raise-type-error 'smtp-sending-end-of-message "thunk" 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))
(define smtp-sending-end-of-message
(make-parameter void
(lambda (f)
(unless (and (procedure? f)
(procedure-arity-includes? f 0))
(raise-type-error 'smtp-sending-end-of-message "thunk" f))
f)))
(log "from~n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf)
(check-reply r 250 w)
(log "to~n")
(for-each
(lambda (dest)
(fprintf w "RCPT TO:<~a>~a" dest crlf)
(check-reply r 250 w))
recipients)
(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)
(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)
;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message))
(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 "dot~n")
(fprintf w ".~a" crlf)
(flush-output w)
(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)))))
(log "from\n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf)
(check-reply r 250 w)
(log "to\n")
(for-each
(lambda (dest)
(fprintf w "RCPT TO:<~a>~a" dest crlf)
(check-reply r 250 w))
recipients)
(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
((smtp-sending-end-of-message))
(log "dot\n")
(fprintf w ".~a" crlf)
(flush-output w)
(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
(require (lib "unit.ss")
"smtp-sig.ss"
"smtp-unit.ss")
(require (lib "unit.ss") "smtp-sig.ss" "smtp-unit.ss")
(define-values/invoke-unit/infer smtp@)

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

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

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

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

157
collects/net/unihead.ss
View File

@ -1,53 +1,53 @@
(module unihead mzscheme
(require (lib "base64.ss" "net")
(lib "qp.ss" "net")
(lib "string.ss"))
(lib "qp.ss" "net")
(lib "string.ss"))
(provide encode-for-header
decode-for-header
generalize-encoding)
decode-for-header
generalize-encoding)
(define re:ascii #rx"^[\u0-\u7F]*$")
(define (encode-for-header s)
(if (regexp-match? re:ascii s)
s
(let ([l (regexp-split #rx"\r\n" s)])
(apply string-append
(map encode-line-for-header l)))))
s
(let ([l (regexp-split #rx"\r\n" s)])
(apply string-append
(map encode-line-for-header l)))))
(define (encode-line-for-header s)
(define (loop s string->bytes charset encode encoding)
;; Find ASCII (and no "=") prefix before a space
(let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
(if m
(string-append
(cadr m)
(loop (caddr m) string->bytes charset encode encoding))
;; Find ASCII (and no "=") suffix after a space
(let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
(if m
(string-append
(loop (cadr m) string->bytes charset encode encoding)
(caddr m))
(format "=?~a?~a?~a?="
charset encoding
(regexp-replace* #rx#"[\r\n]+$"
(encode (string->bytes s))
#"")))))))
(if m
(string-append
(cadr m)
(loop (caddr m) string->bytes charset encode encoding))
;; Find ASCII (and no "=") suffix after a space
(let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
(if m
(string-append
(loop (cadr m) string->bytes charset encode encoding)
(caddr m))
(format "=?~a?~a?~a?="
charset encoding
(regexp-replace* #rx#"[\r\n]+$"
(encode (string->bytes s))
#"")))))))
(cond
[(regexp-match? re:ascii s)
;; ASCII - do nothing
s]
[(regexp-match? #rx"[^\u0-\uFF]" s)
;; Not Latin-1, so use UTF-8
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
[else
;; use Latin-1
(loop s string->bytes/latin-1 "ISO-8859-1"
(lambda (s)
(regexp-replace #rx#" " (qp-encode s) #"_"))
"Q")]))
[(regexp-match? re:ascii s)
;; ASCII - do nothing
s]
[(regexp-match? #rx"[^\u0-\uFF]" s)
;; Not Latin-1, so use UTF-8
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
[else
;; use Latin-1
(loop s string->bytes/latin-1 "ISO-8859-1"
(lambda (s)
(regexp-replace #rx#" " (qp-encode s) #"_"))
"Q")]))
;; ----------------------------------------
@ -73,45 +73,46 @@
(define (decode-for-header s)
(and s
(let ([m (regexp-match re:encoded
(let ([m (regexp-match re:encoded
(string->bytes/latin-1 s (char->integer #\?)))])
(if m
(let ([s ((if (member (cadddr m) '(#"q" #"Q"))
;; quoted-printable, with special _ handling
(lambda (x)
(qp-decode (regexp-replace* #rx#"_" x #" ")))
;; base64:
base64-decode)
(cadddr (cdr m)))]
[encoding (caddr m)])
(string-append
(decode-for-header (bytes->string/latin-1 (cadr m)))
(let ([encoding (generalize-encoding encoding)])
(cond
[(regexp-match? re:utf-8 encoding)
(bytes->string/utf-8 s #\?)]
[else (let ([c (bytes-open-converter
(bytes->string/latin-1 encoding) "UTF-8")])
(if c
(let-values ([(r got status)
(bytes-convert c s)])
(bytes-close-converter c)
(if (eq? status 'complete)
(bytes->string/utf-8 r #\?)
(bytes->string/latin-1 s)))
(bytes->string/latin-1 s)))]))
(let ([rest (cadddr (cddr m))])
(let ([rest
;; A CR-LF-space-encoding sequence means that we
;; should drop the space.
(if (and (> (bytes-length rest) 4)
(= 13 (bytes-ref rest 0))
(= 10 (bytes-ref rest 1))
(= 32 (bytes-ref rest 2))
(let ([m (regexp-match-positions
re:encoded rest)])
(and m (= (caaddr m) 5))))
(subbytes rest 3)
rest)])
(decode-for-header (bytes->string/latin-1 rest))))))
s)))))
(if m
(let ([s ((if (member (cadddr m) '(#"q" #"Q"))
;; quoted-printable, with special _ handling
(lambda (x)
(qp-decode (regexp-replace* #rx#"_" x #" ")))
;; base64:
base64-decode)
(cadddr (cdr m)))]
[encoding (caddr m)])
(string-append
(decode-for-header (bytes->string/latin-1 (cadr m)))
(let ([encoding (generalize-encoding encoding)])
(cond
[(regexp-match? re:utf-8 encoding)
(bytes->string/utf-8 s #\?)]
[else (let ([c (bytes-open-converter
(bytes->string/latin-1 encoding)
"UTF-8")])
(if c
(let-values ([(r got status)
(bytes-convert c s)])
(bytes-close-converter c)
(if (eq? status 'complete)
(bytes->string/utf-8 r #\?)
(bytes->string/latin-1 s)))
(bytes->string/latin-1 s)))]))
(let ([rest (cadddr (cddr m))])
(let ([rest
;; A CR-LF-space-encoding sequence means that we
;; should drop the space.
(if (and (> (bytes-length rest) 4)
(= 13 (bytes-ref rest 0))
(= 10 (bytes-ref rest 1))
(= 32 (bytes-ref rest 2))
(let ([m (regexp-match-positions
re:encoded rest)])
(and m (= (caaddr m) 5))))
(subbytes rest 3)
rest)])
(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
alist->form-urlencoded
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
;; that allows more characters to remain decoded
;; 1/2/2006: Added a mapping for uri path segments
;; that allows more characters to remain decoded
;; -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:
From: Doug Orleans <dougorleans@gmail.com>
@ -50,9 +50,9 @@ Hash: SHA1
Danny Yoo:
> > Just out of curiosity, why is current-alist-separator-mode using
> > semicolons by default rather than ampersands? I understand that
> > flexibility is nice, but this is the fifth time I've seen people hit this
> > Just out of curiosity, why is current-alist-separator-mode using
> > semicolons by default rather than ampersands? I understand that
> > 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?
Robby Findler:
@ -177,200 +177,200 @@ JALQefhDMCATcl2/bZL0bw==
(import)
(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 alphanumeric-mapping
(self-map-chars
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
(define (self-map-char ch) (cons ch ch))
(define (self-map-chars str) (map self-map-char (string->list str)))
;; Characters that sometimes map to themselves
(define safe-mapping (self-map-chars "-_.!~*'()"))
;; The characters that always map to themselves
(define alphanumeric-mapping
(self-map-chars
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
;; The strict URI mapping
(define uri-mapping (append alphanumeric-mapping safe-mapping))
;; Characters that sometimes map to themselves
(define safe-mapping (self-map-chars "-_.!~*'()"))
;; The uri path segment mapping from RFC 3986
(define uri-path-segment-mapping
(append alphanumeric-mapping
safe-mapping
(map (λ (c) (cons c c)) (string->list "@+,=$&:"))))
;; The strict URI mapping
(define uri-mapping (append alphanumeric-mapping safe-mapping))
;; The form-urlencoded mapping
(define form-urlencoded-mapping
`(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
;; The uri path segment mapping from RFC 3986
(define uri-path-segment-mapping
(append alphanumeric-mapping
safe-mapping
(map (λ (c) (cons c c)) (string->list "@+,=$&:"))))
(define (number->hex-string number)
(define (hex n) (string-ref "0123456789ABCDEF" n))
(string #\% (hex (quotient number 16)) (hex (modulo number 16))))
;; The form-urlencoded mapping
(define form-urlencoded-mapping
`(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
(define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16))
(define (number->hex-string number)
(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 (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 ascii-size 128)
(define-values (uri-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping))
;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
(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
uri-path-segment-decoding-vector)
(make-codec-tables uri-path-segment-mapping))
(define-values (uri-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping))
(define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-mapping))
(define-values (uri-path-segment-encoding-vector
uri-path-segment-decoding-vector)
(make-codec-tables uri-path-segment-mapping))
;; vector string -> string
(define (encode table str)
(apply string-append
(map (lambda (byte)
(cond
[(< byte ascii-size)
(vector-ref table byte)]
[else (number->hex-string byte)]))
(bytes->list (string->bytes/utf-8 str)))))
(define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-mapping))
;; vector string -> string
(define (decode table str)
(define internal-decode
(match-lambda
[() (list)]
[(#\% (? hex-digit? char1) (? hex-digit? char2) . rest)
;; This used to consult the table again, but I think that's
;; wrong. For example %2b should produce +, not a space.
(cons (string->number (string char1 char2) 16)
(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))
;; vector string -> string
(define (encode table str)
(apply string-append
(map (lambda (byte)
(cond
[(< byte ascii-size)
(vector-ref table byte)]
[else (number->hex-string byte)]))
(bytes->list (string->bytes/utf-8 str)))))
;; string -> string
(define (uri-decode str)
(decode uri-decoding-vector str))
;; string -> string
(define (uri-path-segment-encode str)
(encode uri-path-segment-encoding-vector str))
;; string -> string
(define (uri-path-segment-decode str)
(decode uri-path-segment-decoding-vector str))
;; vector string -> string
(define (decode table str)
(define internal-decode
(match-lambda
[() (list)]
[(#\% (? hex-digit? char1) (? hex-digit? char2) . rest)
;; This used to consult the table again, but I think that's
;; wrong. For example %2b should produce +, not a space.
(cons (string->number (string char1 char2) 16)
(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)))))
;; string -> string
(define (form-urlencoded-encode str)
(encode form-urlencoded-encoding-vector str))
(define (ascii-char? c)
(< (char->integer c) ascii-size))
;; string -> string
(define (form-urlencoded-decode str)
(decode form-urlencoded-decoding-vector str))
(define (hex-digit? c)
(or (char<=? #\0 c #\9)
(char<=? #\a c #\f)
(char<=? #\A c #\F)))
;; 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 -> string
(define (uri-encode str)
(encode uri-encoding-vector str))
;; 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 '())]))))
;; string -> string
(define (uri-decode str)
(decode uri-decoding-vector str))
(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))))
;; string -> string
(define (uri-path-segment-encode str)
(encode uri-path-segment-encoding-vector str))
;; string -> string
(define (uri-path-segment-decode str)
(decode uri-path-segment-decoding-vector str))
;; 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

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

@ -1,8 +1,6 @@
(module uri-codec mzscheme
(require (lib "unit.ss")
"uri-codec-sig.ss"
"uri-codec-unit.ss")
(require (lib "unit.ss") "uri-codec-sig.ss" "uri-codec-unit.ss")
(provide-signature-elements uri-codec^)
(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
url-exception?
current-proxy-servers)

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

@ -30,419 +30,418 @@
(import tcp^)
(export url^)
(define-struct (url-exception exn:fail) ())
(define-struct (url-exception exn:fail) ())
(define current-proxy-servers
(make-parameter null
(lambda (v)
(unless (and (list? v)
(andmap
(lambda (v)
(and (list? v)
(= 3 (length v))
(equal? (car v) "http")
(string? (car v))
(number? (caddr v))
(exact? (caddr v))
(integer? (caddr v))
(<= 1 (caddr v) 65535)))
v))
(raise-type-error
'current-proxy-servers
"list of list of scheme, string, and exact integer in [1,65535]"
v))
(apply
list-immutable
(map (lambda (v)
(list-immutable (string->immutable-string (car v))
(string->immutable-string (cadr v))
(caddr v)))
v)))))
(define current-proxy-servers
(make-parameter null
(lambda (v)
(unless (and (list? v)
(andmap
(lambda (v)
(and (list? v)
(= 3 (length v))
(equal? (car v) "http")
(string? (car v))
(number? (caddr v))
(exact? (caddr v))
(integer? (caddr v))
(<= 1 (caddr v) 65535)))
v))
(raise-type-error
'current-proxy-servers
"list of list of scheme, string, and exact integer in [1,65535]"
v))
(apply
list-immutable
(map (lambda (v)
(list-immutable (string->immutable-string (car v))
(string->immutable-string (cadr v))
(caddr v)))
v)))))
(define (url-error fmt . args)
(let ([s (string->immutable-string
(apply format fmt
(map (lambda (arg)
(if (url? arg) (url->string arg) arg))
args)))])
(raise (make-url-exception s (current-continuation-marks)))))
(define (url-error fmt . args)
(let ([s (string->immutable-string
(apply format fmt
(map (lambda (arg)
(if (url? arg) (url->string arg) arg))
args)))])
(raise (make-url-exception s (current-continuation-marks)))))
(define (url->string url)
(let ([scheme (url-scheme url)]
[user (url-user url)]
[host (url-host url)]
[port (url-port url)]
[path (url-path url)]
[query (url-query url)]
[fragment (url-fragment url)]
[sa string-append])
(sa (if scheme (sa scheme ":") "")
(if (or user host port)
(sa "//"
(if user (sa (uri-encode user) "@") "")
(if host host "")
(if port (sa ":" (number->string port)) "")
;; There used to be a "/" here, but that causes an
;; extra leading slash -- wonder why it ever worked!
)
"")
(combine-path-strings (url-path-absolute? url) path)
;; (if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
(if fragment (sa "#" (uri-encode fragment)) ""))))
(define (url->string url)
(let ([scheme (url-scheme url)]
[user (url-user url)]
[host (url-host url)]
[port (url-port url)]
[path (url-path url)]
[query (url-query url)]
[fragment (url-fragment url)]
[sa string-append])
(sa (if scheme (sa scheme ":") "")
(if (or user host port)
(sa "//"
(if user (sa (uri-encode user) "@") "")
(if host host "")
(if port (sa ":" (number->string port)) "")
;; There used to be a "/" here, but that causes an
;; extra leading slash -- wonder why it ever worked!
)
"")
(combine-path-strings (url-path-absolute? url) path)
;; (if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
(if fragment (sa "#" (uri-encode fragment)) ""))))
;; url->default-port : url -> num
(define (url->default-port url)
(let ([scheme (url-scheme url)])
(cond [(not scheme) 80]
[(string=? scheme "http") 80]
[(string=? scheme "https") 443]
[else (url-error "Scheme ~a not supported" (url-scheme url))])))
;; url->default-port : url -> num
(define (url->default-port url)
(let ([scheme (url-scheme url)])
(cond [(not scheme) 80]
[(string=? scheme "http") 80]
[(string=? scheme "https") 443]
[else (url-error "Scheme ~a not supported" (url-scheme url))])))
;; make-ports : url -> in-port x out-port
(define (make-ports url proxy)
(let ([port-number (if proxy
(caddr proxy)
(or (url-port url) (url->default-port url)))]
[host (if proxy
(cadr proxy)
(url-host url))])
(tcp-connect host port-number)))
;; make-ports : url -> in-port x out-port
(define (make-ports url proxy)
(let ([port-number (if proxy
(caddr proxy)
(or (url-port url) (url->default-port url)))]
[host (if proxy
(cadr proxy)
(url-host url))])
(tcp-connect host port-number)))
;; 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)
(let*-values
([(proxy) (assoc (url-scheme url) (current-proxy-servers))]
[(server->client client->server) (make-ports url proxy)]
[(access-string) (url->string
(if proxy
url
(make-url #f #f #f #f
(url-path-absolute? url)
(url-path url)
(url-query url)
(url-fragment url))))])
(define (println . xs)
(for-each (lambda (x) (display x client->server)) xs)
(display "\r\n" client->server))
(println (if get? "GET " "POST ") access-string " HTTP/1.0")
(println "Host: " (url-host url)
(let ([p (url-port url)]) (if p (format ":~a" p) "")))
(when post-data (println "Content-Length: " (bytes-length post-data)))
(for-each println strings)
(println)
(when post-data (display post-data client->server))
(flush-output client->server)
(tcp-abandon-port client->server)
server->client))
;; 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)
(let*-values
([(proxy) (assoc (url-scheme url) (current-proxy-servers))]
[(server->client client->server) (make-ports url proxy)]
[(access-string) (url->string
(if proxy
url
(make-url #f #f #f #f
(url-path-absolute? url)
(url-path url)
(url-query url)
(url-fragment url))))])
(define (println . xs)
(for-each (lambda (x) (display x client->server)) xs)
(display "\r\n" client->server))
(println (if get? "GET " "POST ") access-string " HTTP/1.0")
(println "Host: " (url-host url)
(let ([p (url-port url)]) (if p (format ":~a" p) "")))
(when post-data (println "Content-Length: " (bytes-length post-data)))
(for-each println strings)
(println)
(when post-data (display post-data client->server))
(flush-output client->server)
(tcp-abandon-port client->server)
server->client))
(define (file://->path url)
;; remove all ""s
(let ([elts (remove* '("") (map path/param-path (url-path url)))]
[abs? (url-path-absolute? url)])
;; See the discussion in PR8060 for an explanation
(if (eq? 'windows url:os-type)
(let ([host (or (url-host url) "")])
(unless (equal? "" host) (set! elts (cons host elts)))
(if (null? elts)
(build-path) ; make it throw the error
(let* ([fst (car elts)] [len (string-length fst)])
(if (or (not abs?) (eq? #\: (string-ref fst (sub1 len))))
(apply build-path elts)
(if (null? (cdr elts))
(build-path (string-append "\\\\" (car elts)))
(apply build-path
(string-append "\\\\" (car elts) "\\" (cadr elts))
(cddr elts)))))))
(apply build-path (if abs? (cons "/" elts) elts)))))
(define (file://->path url)
;; remove all ""s
(let ([elts (remove* '("") (map path/param-path (url-path url)))]
[abs? (url-path-absolute? url)])
;; See the discussion in PR8060 for an explanation
(if (eq? 'windows url:os-type)
(let ([host (or (url-host url) "")])
(unless (equal? "" host) (set! elts (cons host elts)))
(if (null? elts)
(build-path) ; make it throw the error
(let* ([fst (car elts)] [len (string-length fst)])
(if (or (not abs?) (eq? #\: (string-ref fst (sub1 len))))
(apply build-path elts)
(if (null? (cdr elts))
(build-path (string-append "\\\\" (car elts)))
(apply build-path
(string-append "\\\\" (car elts) "\\" (cadr elts))
(cddr elts)))))))
(apply build-path (if abs? (cons "/" elts) elts)))))
;; file://get-pure-port : url -> in-port
(define (file://get-pure-port url)
(open-input-file (file://->path url)))
;; file://get-pure-port : url -> in-port
(define (file://get-pure-port url)
(open-input-file (file://->path url)))
(define (schemeless-url url)
(url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
(define (schemeless-url 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
(define (getpost-impure-port get? url post-data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
(http://getpost-impure-port get? url post-data strings)]
[(string=? scheme "file")
(url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; getpost-impure-port : bool x url x list (str) -> in-port
(define (getpost-impure-port get? url post-data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
(http://getpost-impure-port get? url post-data strings)]
[(string=? scheme "file")
(url-error "There are no impure file: ports")]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; get-impure-port : url [x list (str)] -> in-port
(define get-impure-port
(case-lambda
[(url) (get-impure-port url '())]
[(url strings) (getpost-impure-port #t url #f strings)]))
;; get-impure-port : url [x list (str)] -> in-port
(define get-impure-port
(case-lambda
[(url) (get-impure-port url '())]
[(url strings) (getpost-impure-port #t url #f strings)]))
;; post-impure-port : url x bytes [x list (str)] -> in-port
(define post-impure-port
(case-lambda
[(url post-data) (post-impure-port url post-data '())]
[(url post-data strings)
(getpost-impure-port #f url post-data strings)]))
;; post-impure-port : url x bytes [x list (str)] -> in-port
(define post-impure-port
(case-lambda
[(url post-data) (post-impure-port url post-data '())]
[(url post-data strings)
(getpost-impure-port #f url post-data strings)]))
;; getpost-pure-port : bool x url x list (str) -> in-port
(define (getpost-pure-port get? url post-data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
(let ([port (http://getpost-impure-port
get? url post-data strings)])
(with-handlers ([void (lambda (exn)
(close-input-port port)
(raise exn))])
(purify-port port))
port)]
[(string=? scheme "file")
(file://get-pure-port url)]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; getpost-pure-port : bool x url x list (str) -> in-port
(define (getpost-pure-port get? url post-data strings)
(let ([scheme (url-scheme url)])
(cond [(not scheme)
(schemeless-url url)]
[(or (string=? scheme "http")
(string=? scheme "https"))
(let ([port (http://getpost-impure-port
get? url post-data strings)])
(with-handlers ([void (lambda (exn)
(close-input-port port)
(raise exn))])
(purify-port port))
port)]
[(string=? scheme "file")
(file://get-pure-port url)]
[else (url-error "Scheme ~a unsupported" scheme)])))
;; get-pure-port : url [x list (str)] -> in-port
(define get-pure-port
(case-lambda
[(url) (get-pure-port url '())]
[(url strings) (getpost-pure-port #t url #f strings)]))
;; get-pure-port : url [x list (str)] -> in-port
(define get-pure-port
(case-lambda
[(url) (get-pure-port url '())]
[(url strings) (getpost-pure-port #t url #f strings)]))
;; post-pure-port : url bytes [x list (str)] -> in-port
(define post-pure-port
(case-lambda
[(url post-data) (post-pure-port url post-data '())]
[(url post-data strings) (getpost-pure-port #f url post-data strings)]))
;; post-pure-port : url bytes [x list (str)] -> in-port
(define post-pure-port
(case-lambda
[(url post-data) (post-pure-port url post-data '())]
[(url post-data strings) (getpost-pure-port #f url post-data strings)]))
;; display-pure-port : in-port -> ()
(define (display-pure-port server->client)
(copy-port server->client (current-output-port))
(close-input-port server->client))
;; display-pure-port : in-port -> ()
(define (display-pure-port server->client)
(copy-port server->client (current-output-port))
(close-input-port server->client))
(define (empty-url? url)
(and (not (url-scheme url))
(not (url-query url))
(not (url-fragment url))
(null? (url-path url))))
(define (empty-url? url)
(and (not (url-scheme url))
(not (url-query url))
(not (url-fragment url))
(null? (url-path url))))
;; transliteration of code in rfc 3986, section 5.2.2
(define (combine-url/relative Base string)
(let ([R (string->url string)]
[T (make-url #f #f #f #f #f '() '() #f)])
(if (url-scheme R)
(begin
(set-url-scheme! T (url-scheme R))
(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 (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")
;; transliteration of code in rfc 3986, section 5.2.2
(define (combine-url/relative Base string)
(let ([R (string->url string)]
[T (make-url #f #f #f #f #f '() '() #f)])
(if (url-scheme R)
(begin
(set-url-scheme! T (url-scheme R))
(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 (url-host R) ;; => authority is defined
(begin
(set-url-scheme! url
(if (char=? (string-ref string 0) #\/) "file" "http"))
url)))))
(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))
;; string->url : str -> url
;; New implementation, mostly provided by Neil Van Dyke
(define url-rx
(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 (all-but-last lst)
(cond [(null? lst) null]
[(null? (cdr lst)) null]
[else (cons (car lst) (all-but-last (cdr lst)))]))
(define (uri-decode/maybe f)
;; If #f, and leave unmolested any % that is followed by hex digit
;; 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"))))
;; 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))])))
;; separate-path-strings : string[starting with /] -> (listof path/param)
(define (separate-path-strings str)
(let ([strs (regexp-split #rx"/" str)])
(map separate-params (if (string=? "" (car strs)) (cdr strs) strs))))
;; 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)])))
(define (separate-params s)
(let ([lst (map path-segment-decode (regexp-split #rx";" s))])
(make-path/param (car lst) (cdr lst))))
;; 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 (path-segment-decode p)
(cond [(string=? p "..") 'up]
[(string=? p ".") 'same]
[else (uri-path-segment-decode p)]))
(define character-set-size 256)
(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)]))
;; 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
(set-url-scheme! url
(if (char=? (string-ref string 0) #\/) "file" "http"))
url)))))
(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))]))
;; string->url : str -> url
;; New implementation, mostly provided by Neil Van Dyke
(define url-rx
(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)
(join ";" (map path-segment-encode
(cons (path/param-path s) (path/param-param s)))))
(define (uri-decode/maybe f)
;; If #f, and leave unmolested any % that is followed by hex digit
;; 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)
(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))))]))
;; separate-path-strings : string[starting with /] -> (listof path/param)
(define (separate-path-strings str)
(let ([strs (regexp-split #rx"/" str)])
(map separate-params (if (string=? "" (car strs)) (cdr strs) strs))))
))
(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
(require (lib "unit.ss")
(lib "contract.ss")
"url-structs.ss"
"url-structs.ss"
"url-sig.ss"
"url-unit.ss"
"tcp-sig.ss"
@ -10,7 +10,7 @@
(define-compound-unit/infer url+tcp@
(import) (export url^)
(link tcp@ url@))
(define-values/invoke-unit/infer url+tcp@)
(provide
@ -36,10 +36,10 @@
(purify-port (input-port? . -> . string?))
(netscape/string->url (string? . -> . url?))
(call/input-url (opt->* (url?
(opt-> (url?) ((listof string?)) input-port?)
(input-port? . -> . any))
((listof string?))
any))
(opt-> (url?) ((listof string?)) input-port?)
(input-port? . -> . any))
((listof string?))
any))
(combine-url/relative (url? string? . -> . url?))
(url-exception? (any/c . -> . boolean?))
(current-proxy-servers