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

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

@ -20,4 +20,3 @@
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

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

@ -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,21 +253,22 @@
;; quoted-pair = "\" CHAR
;;
;; implementation note: I have chosen to use a regular expression rather than
;; a character set for this definition because of two dependencies: CRLF must appear
;; as a block to be legal, and " may only appear as \"
(define rfc2068:quoted-string?
(lambda (s)
(if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s)
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 "\\\\\"") "\""))
@ -278,7 +276,7 @@
(define (to-rfc2109:value s)
(cond
[(not (string? s))
(raise (build-cookie-error (format "Expected string, given: ~e" s)))]
(cookie-error "Expected string, given: ~e" s)]
;; for backwards compatibility, just use the given string if it will work
[(rfc2068:token? s) s]
@ -289,9 +287,7 @@
[(rfc2068:quoted-string? (convert-to-quoted s))
=> (λ (x) x)]
[else
(raise
(build-cookie-error
(format "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)))]))
(cookie-error "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
;;!
;;
@ -304,7 +300,7 @@
(define cookie-string?
(opt-lambda (s (value? #t))
(unless (string? s)
(raise (build-cookie-error (format "String expected, received: ~a" s))))
(cookie-error "String expected, received: ~a" s))
(if value?
(rfc2109:value? s)
;; name: token
@ -312,31 +308,21 @@
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
(define char-set:hostname
(let ((a-z-lowercase (ucs-range->char-set #x61 #x7B))
(a-z-uppercase (ucs-range->char-set #x41 #x5B)))
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
(char-set-adjoin!
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
#\. )))
#\.)))
(define valid-domain?
(lambda (dom)
(and
;; Domain must start with a dot (.)
(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)))
)

4
collects/net/cookie.ss
View File

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

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

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

566
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)]
;;
[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-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-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-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-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
;; 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"))
(lambda ()
(let ([s (make-bytes 512)])
(let retry ([timeout INIT-TIMEOUT])
(udp-send-to udp nameserver 53 (list->bytes query))
(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"]))))
(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))))))))
(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))])
(lambda ()
(udp-close udp)))])
(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)))))))
; 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"))
(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 ([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 (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 ([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 (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)))))))))
(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 (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 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 (get-ptr-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
ans))
(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 (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 (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
(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 (get-a-list-from-ans ans)
(filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
ans))
(define (dns-get-address nameserver addr)
(or (try-forwarding
(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@)

10
collects/net/doc.txt
View File

@ -498,11 +498,11 @@ 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
[#: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

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

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

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

@ -3,213 +3,215 @@
;; 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))
;; opqaue record to represent an FTP connection:
(define-struct tcp-connection (in out))
(define tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
(define tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
(define re:response-end #rx#"^[0-9][0-9][0-9] ")
(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
(define re:response-end #rx#"^[0-9][0-9][0-9] ")
(define (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 (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)])))
;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any
;;
;; Checks a standard-format response, checking for the given
;; expected 3-digit result code if expected is not #f.
;;
;; While checking, the function sends reponse lines to
;; diagnostic-accum. This function -accum functions can return a
;; value that accumulates over multiple calls to the function, and
;; accum-start is used as the initial value. Use `void' and
;; `(void)' to ignore the response info.
;;
;; If an unexpected result is found, an exception is raised, and the
;; stream is left in an undefined state.
(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
(flush-output tcpout)
(let ([line (read-bytes-line tcpin 'any)])
(cond
[(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:multi-response-start line)
(check-expected-result line expected)
(let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
(let loop ([accum (diagnostic-accum line accum-start)])
(let ([line (read-bytes-line tcpin 'any)])
(cond [(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:done line)
(diagnostic-accum line accum)]
[else
(loop (diagnostic-accum line accum))]))))]
[(regexp-match re:response-end line)
(check-expected-result line expected)
(diagnostic-accum line accum-start)]
[else
(error 'ftp "unexpected result: ~e" line)])))
(define (get-month month-bytes)
(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 (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)]))
(define (bytes->number bytes)
(string->number (bytes->string/latin-1 bytes)))
(define (bytes->number bytes)
(string->number (bytes->string/latin-1 bytes)))
(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
(define (ftp-make-file-seconds ftp-date-str)
(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 (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#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(define (establish-data-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "PASV~n")
(let ([response (ftp-check-response (tcp-connection-in tcp-ports)
(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 (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))))
;; Used where version 0.1a printed responses:
(define (print-msg s ignore)
;; (printf "~a~n" s)
(void))
;; Used where version 0.1a printed responses:
(define (print-msg s ignore)
;; (printf "~a\n" s)
(void))
(define (ftp-establish-connection* in out username password)
(ftp-check-response in out #"220" print-msg (void))
(display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
(let ([no-password? (ftp-check-response in out (list #"331" #"230")
(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* 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 (ftp-establish-connection server-address server-port username password)
(let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
(ftp-establish-connection* tcpin tcpout username password)))
(define (ftp-close-connection tcp-ports)
(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-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 (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 (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 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-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)))
(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")
)
;; (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)

692
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 CRLF (string #\return #\newline))
(define CRLF/bytes #"\r\n")
(define empty-header CRLF)
(define empty-header/bytes CRLF/bytes)
(define empty-header CRLF)
(define empty-header/bytes CRLF/bytes)
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
(define re:field-start (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 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 (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 (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 (make-field-start-regexp field)
(regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
(define (remove-field field header)
(replace-field field #f header))
(define (make-field-start-regexp/bytes field)
(byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
(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-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 (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))))))
;; It's slightly less obvious how to generalize the functions that don't
;; accept a header as input; for lack of an obvious solution (and free time),
;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
(define (replace-field field data header)
(if (bytes? header)
(let ([m (regexp-match-positions
(make-field-start-regexp/bytes field)
header)])
(define (standard-message-header from tos ccs bccs subject)
(let ([h (insert-field
"Subject" subject
(insert-field
"Date" (parameterize ([date-display-format 'rfc2822])
(date->string (seconds->date (current-seconds)) #t))
CRLF))])
;; NOTE: bccs don't go into the header; that's why they're "blind"
(let ([h (if (null? ccs)
h
(insert-field "CC" (assemble-address-field ccs) h))])
(let ([h (if (null? tos)
h
(insert-field "To" (assemble-address-field tos) h))])
(insert-field "From" from h)))))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply string-append
(map (lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas)
(splice datas "\r\n\t"))
;; Extracting Addresses ;;
(define blank "[ \t\n\r\v]")
(define nonblank "[^ \t\n\r\v]")
(define re:all-blank (regexp (format "^~a*$" blank)))
(define re:quoted (regexp "\"[^\"]*\""))
(define re:parened (regexp "[(][^)]*[)]"))
(define re:comma (regexp ","))
(define re:comma-separated (regexp "([^,]*),(.*)"))
(define (extract-addresses s form)
(unless (memq form '(name address full all))
(raise-type-error 'extract-addresses
"form: 'name, 'address, 'full, or 'all"
form))
(if (or (not s) (regexp-match re:all-blank s))
null
(let loop ([prefix ""][s s])
;; Which comes first - a quote or a comma?
(let* ([mq1 (regexp-match-positions re:quoted s)]
[mq2 (regexp-match-positions re:parened s)]
[mq (if (and mq1 mq2)
(if (< (caar mq1) (caar mq2))
mq1
mq2)
(or mq1 mq2))]
[mc (regexp-match-positions re:comma s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
;; Quote contains a comma
(loop (string-append
prefix
(substring s 0 (cdar mq)))
(substring s (cdar mq) (string-length s)))
;; Normal comma parsing:
(let ([m (regexp-match re:comma-separated s)])
(if m
(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)))))
(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 (remove-field field header)
(replace-field field #f header))
(define (select-result form name addr full)
(case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(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 (one-result form s)
(select-result form s s s))
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
(define re:double-less (regexp "<.*<"))
(define re:double-greater (regexp ">.*>"))
(define re:bad-chars (regexp "[,\"()<>]"))
(define re:tail-blanks (regexp (format "~a+$" blank)))
(define re:head-blanks (regexp (format "^~a+" blank)))
(define (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-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-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))))))
(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)))))
;; 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 (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 (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 ([n (extract-one-name (string-append prefix (cadr m)) form)]
[rest (extract-addresses (caddr m) form)])
(cons n rest))
(let ([n (extract-one-name (string-append prefix s) form)])
(list n)))))))))
(define (select-result form name addr full)
(case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(define (one-result form s)
(select-result form s s s))
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
(define re:double-less (regexp "<.*<"))
(define re:double-greater (regexp ">.*>"))
(define re:bad-chars (regexp "[,\"()<>]"))
(define re:tail-blanks (regexp (format "~a+$" blank)))
(define re:head-blanks (regexp (format "^~a+" blank)))
(define (extract-one-name orig form)
(let loop ([s orig][form form])
(cond
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
[(regexp-match re:parened-name s)
=> (lambda (m)
(let ([name (caddr m)]
[all (loop (cadr m) 'all)])
(select-result form
(if (string=? (car all) (cadr all))
name
(car all))
(cadr all)
(format "~a (~a)" (caddr all) name))))]
[(regexp-match re:quoted-name s)
=> (lambda (m)
(let ([name (cadr m)]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(regexp-match re:simple-name s)
=> (lambda (m)
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
[addr (extract-angle-addr (caddr m) s)])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(or (regexp-match "<" s) (regexp-match ">" s))
(one-result form (extract-angle-addr s orig))]
[else
(one-result form (extract-simple-addr s orig))])))
(define (extract-angle-addr s orig)
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
(error 'extract-address "too many angle brackets: ~a" s)
(let ([m (regexp-match re:normal-name s)])
(if m
(extract-simple-addr (cadr m) orig)
(error 'extract-address "cannot parse address: ~a" orig)))))
(define (extract-simple-addr s orig)
(cond
[(regexp-match re:bad-chars s)
(error 'extract-address "cannot parse address: ~a" orig)]
[else
;; final whitespace strip
(regexp-replace
re:tail-blanks
(regexp-replace re:head-blanks s "")
"")]))
(define (assemble-address-field addresses)
(if (null? addresses)
""
(let loop ([addresses (cdr addresses)]
[s (car addresses)]
[len (string-length (car addresses))])
(if (null? addresses)
s
(let* ([addr (car addresses)]
[alen (string-length addr)])
(if (<= 72 (+ len alen))
(loop (cdr addresses)
(format "~a,~a~a~a~a"
s #\return #\linefeed
#\tab addr)
alen)
(loop (cdr addresses)
(format "~a, ~a" s addr)
(+ len alen 2)))))))))
(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@)

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

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

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

File diff suppressed because it is too large Load Diff

5
collects/net/imap.ss
View File

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

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

File diff suppressed because it is too large Load Diff

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

@ -40,22 +40,22 @@
;; that has character c
(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

4
collects/net/mime.ss
View File

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

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

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

598
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
;; 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)))))]))
(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)])))]))
;; connect-to-server :
;; string [x number] -> commnicator
;; connect-to-server :
;; string [x number] -> commnicator
(define connect-to-server
(opt-lambda (server-name (port-number default-nntpd-port-number))
(let-values (((receiver sender)
(tcp-connect server-name port-number)))
(connect-to-server* receiver sender server-name port-number))))
(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))))
;; close-communicator :
;; communicator -> ()
;; close-communicator :
;; communicator -> ()
(define close-communicator
(lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
(define close-communicator
(lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
;; disconnect-from-server :
;; communicator -> ()
;; disconnect-from-server :
;; 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 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.
;; 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)))
(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)
;; make-desired-header :
;; string -> desired
(define newnews-since
(generic-message-command "NEWNEWS" 230))
(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))))
":"))))
;; 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))))
":"))))
;; 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@)

675
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))))))]))
(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
;; connect-to-server :
;; string [x number] -> communicator
(define connect-to-server
(opt-lambda (server-name (port-number default-pop-port-number))
(let-values (((receiver sender) (tcp-connect server-name port-number)))
(connect-to-server* receiver sender 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))))
;; authenticate/plain-text :
;; string x string x communicator -> ()
;; authenticate/plain-text :
;; string x string x communicator -> ()
;; -- if authentication succeeds, sets the communicator's state to
;; transaction.
;; -- if authentication succeeds, sets the communicator's state to
;; transaction.
(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"))))))))
(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"))])))))
;; get-mailbox-status :
;; communicator -> number x number
;; get-mailbox-status :
;; communicator -> number x number
;; -- returns number of messages and number of octets.
;; -- returns number of messages and number of octets.
(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-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)))))
;; get-message/complete :
;; communicator x number -> list (string) x list (string)
;; get-message/complete :
;; communicator x number -> list (string) x 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/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/headers :
;; communicator x number -> list (string)
;; get-message/headers :
;; 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/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/body :
;; communicator x number -> list (string)
;; get-message/body :
;; communicator x number -> list (string)
(define get-message/body
(lambda (communicator message)
(let-values (((headers body)
(get-message/complete communicator message)))
body)))
(define get-message/body
(lambda (communicator message)
(let-values ([(headers body) (get-message/complete communicator message)])
body)))
;; split-header/body :
;; list (string) -> list (string) x list (string)
;; split-header/body :
;; list (string) -> list (string) x list (string)
;; -- returns list of headers and list of body lines.
;; -- returns list of headers and list of body lines.
(define split-header/body
(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 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))))))))
;; delete-message :
;; communicator x number -> ()
;; delete-message :
;; communicator x number -> ()
(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 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]))))
;; regexp for UIDL responses
;; regexp for UIDL responses
(define uidl-regexp #rx"([0-9]+) (.*)")
(define uidl-regexp #rx"([0-9]+) (.*)")
;; get-unique-id/single :
;; communicator x number -> string
;; get-unique-id/single :
;; communicator x number -> 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/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/all :
;; communicator -> list(number x string)
;; get-unique-id/all :
;; communicator -> list(number x string)
(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 (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))))
;; close-communicator :
;; communicator -> ()
;; close-communicator :
;; communicator -> ()
(define close-communicator
(lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
(define close-communicator
(lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
;; disconnect-from-server :
;; communicator -> ()
;; disconnect-from-server :
;; 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))))))
(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)]))))
;; send-to-server :
;; communicator x format-string x list (values) -> ()
;; send-to-server :
;; communicator x format-string x list (values) -> ()
(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 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))))
;; get-one-line-from-server :
;; iport -> string
;; get-one-line-from-server :
;; iport -> string
(define get-one-line-from-server
(lambda (server->client-port)
(read-line server->client-port 'return-linefeed)))
(define get-one-line-from-server
(lambda (server->client-port)
(read-line server->client-port 'return-linefeed)))
;; get-server-status-response :
;; communicator -> server-responses x string
;; get-server-status-response :
;; communicator -> server-responses x string
;; -- 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.
;; -- 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)))
(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)
|#

374
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,164 +33,164 @@
(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!)
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
@ -208,13 +208,13 @@
;; left-rotate-adjust!
(lambda (t old-right)
(set-tree-left-count! old-right (+ 1
(tree-left-count old-right)
(tree-left-count t))))
(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)
|#

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

@ -32,142 +32,142 @@
(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))
;; 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-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))))
;; 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 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 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-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 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 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 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))]))))))
(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)))))
;; 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

4
collects/net/qp.ss
View File

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

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

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

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

154
collects/net/sendurl.ss
View File

@ -28,77 +28,77 @@
(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
@ -122,22 +122,22 @@
; 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)

214
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-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)
(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))
(when auth-user
(log "auth\n")
(fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF
(base64-encode
(string->bytes/latin-1
(format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w))
(log "from~n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf)
(check-reply r 250 w)
(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 "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)
(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))
;; 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 "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)
(log "quit\n")
(fprintf w "QUIT~a" crlf)
(check-reply r 221 w)
(close-output-port w)
(close-input-port r)))
(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)))))
(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@)

98
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"))
(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)
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^)
(import)
(export tcp^)
(define ctx (ssl-make-client-context))
(when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file
(ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files
(ssl-set-verify! ctx #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! ctx f))
client-root-cert-files))
(define ctx (ssl-make-client-context))
(when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file
(ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files
(ssl-set-verify! ctx #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! ctx f))
client-root-cert-files))
(define (tcp-abandon-port p)
(if (input-port? p)
(close-input-port p)
(close-output-port p)))
(define (tcp-abandon-port p)
(if (input-port? p)
(close-input-port p)
(close-output-port p)))
(define tcp-accept ssl-accept)
(define tcp-accept/enable-break ssl-accept/enable-break)
(define tcp-accept ssl-accept)
(define tcp-accept/enable-break ssl-accept/enable-break)
;; accept-ready? doesn't really work for SSL:
(define (tcp-accept-ready? p)
#f)
;; accept-ready? doesn't really work for SSL:
(define (tcp-accept-ready? p)
#f)
(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-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-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?))))
(define tcp-listener? ssl-listener?))))

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

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

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

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

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

@ -178,199 +178,199 @@ 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)))
(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"))
;; The characters that always map to themselves
(define alphanumeric-mapping
(self-map-chars
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
;; Characters that sometimes map to themselves
(define safe-mapping (self-map-chars "-_.!~*'()"))
;; Characters that sometimes map to themselves
(define safe-mapping (self-map-chars "-_.!~*'()"))
;; The strict URI mapping
(define uri-mapping (append alphanumeric-mapping safe-mapping))
;; The strict URI mapping
(define uri-mapping (append alphanumeric-mapping safe-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 "@+,=$&:"))))
;; 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 form-urlencoded mapping
(define form-urlencoded-mapping
`(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
;; The form-urlencoded mapping
(define form-urlencoded-mapping
`(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
(define (number->hex-string number)
(define (hex n) (string-ref "0123456789ABCDEF" n))
(string #\% (hex (quotient number 16)) (hex (modulo number 16))))
(define (number->hex-string number)
(define (hex n) (string-ref "0123456789ABCDEF" n))
(string #\% (hex (quotient number 16)) (hex (modulo number 16))))
(define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16))
(define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16))
(define ascii-size 128)
(define ascii-size 128)
;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
(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)))
;; (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-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping))
(define-values (uri-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping))
(define-values (uri-path-segment-encoding-vector
uri-path-segment-decoding-vector)
(make-codec-tables uri-path-segment-mapping))
(define-values (uri-path-segment-encoding-vector
uri-path-segment-decoding-vector)
(make-codec-tables uri-path-segment-mapping))
(define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-mapping))
(define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-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)))))
;; 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)))))
;; 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)))))
;; 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 (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)))
(define (hex-digit? c)
(or (char<=? #\0 c #\9)
(char<=? #\a c #\f)
(char<=? #\A c #\F)))
;; string -> string
(define (uri-encode str)
(encode uri-encoding-vector str))
;; string -> string
(define (uri-encode str)
(encode uri-encoding-vector str))
;; string -> string
(define (uri-decode str)
(decode uri-decoding-vector 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-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 (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-encode str)
(encode form-urlencoded-encoding-vector str))
;; string -> string
(define (form-urlencoded-decode str)
(decode form-urlencoded-decoding-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)))
;; 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 '())]))))
;; 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))))
(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

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

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

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

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

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

10
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"
@ -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