diff --git a/collects/net/base64-sig.ss b/collects/net/base64-sig.ss
index 242f953..a56c288 100644
--- a/collects/net/base64-sig.ss
+++ b/collects/net/base64-sig.ss
@@ -4,4 +4,3 @@
base64-decode-stream
base64-encode
base64-decode)
-
diff --git a/collects/net/base64-unit.ss b/collects/net/base64-unit.ss
index 730b9a0..e84e001 100644
--- a/collects/net/base64-unit.ss
+++ b/collects/net/base64-unit.ss
@@ -4,137 +4,131 @@
(import)
(export base64^)
- (define base64-digit (make-vector 256))
- (let loop ([n 0])
- (unless (= n 256)
- (cond
- [(<= (char->integer #\A) n (char->integer #\Z))
- (vector-set! base64-digit n (- n (char->integer #\A)))]
- [(<= (char->integer #\a) n (char->integer #\z))
- (vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))]
- [(<= (char->integer #\0) n (char->integer #\9))
- (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))]
- [(= (char->integer #\+) n)
- (vector-set! base64-digit n 62)]
- [(= (char->integer #\/) n)
- (vector-set! base64-digit n 63)]
- [else
- (vector-set! base64-digit n #f)])
- (loop (add1 n))))
+ (define base64-digit (make-vector 256))
+ (let loop ([n 0])
+ (unless (= n 256)
+ (cond [(<= (char->integer #\A) n (char->integer #\Z))
+ (vector-set! base64-digit n (- n (char->integer #\A)))]
+ [(<= (char->integer #\a) n (char->integer #\z))
+ (vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))]
+ [(<= (char->integer #\0) n (char->integer #\9))
+ (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))]
+ [(= (char->integer #\+) n)
+ (vector-set! base64-digit n 62)]
+ [(= (char->integer #\/) n)
+ (vector-set! base64-digit n 63)]
+ [else
+ (vector-set! base64-digit n #f)])
+ (loop (add1 n))))
- (define digit-base64 (make-vector 64))
- (define (each-char s e pos)
- (let loop ([i (char->integer s)][pos pos])
- (unless (> i (char->integer e))
- (vector-set! digit-base64 pos i)
- (loop (add1 i) (add1 pos)))))
- (each-char #\A #\Z 0)
- (each-char #\a #\z 26)
- (each-char #\0 #\9 52)
- (each-char #\+ #\+ 62)
- (each-char #\/ #\/ 63)
-
- (define (base64-filename-safe)
- (vector-set! base64-digit (char->integer #\-) 62)
- (vector-set! base64-digit (char->integer #\_) 63)
- (each-char #\- #\- 62)
- (each-char #\_ #\_ 63))
+ (define digit-base64 (make-vector 64))
+ (define (each-char s e pos)
+ (let loop ([i (char->integer s)][pos pos])
+ (unless (> i (char->integer e))
+ (vector-set! digit-base64 pos i)
+ (loop (add1 i) (add1 pos)))))
+ (each-char #\A #\Z 0)
+ (each-char #\a #\z 26)
+ (each-char #\0 #\9 52)
+ (each-char #\+ #\+ 62)
+ (each-char #\/ #\/ 63)
- (define (base64-decode-stream in out)
- (let loop ([waiting 0][waiting-bits 0])
- (if (>= waiting-bits 8)
- (begin
- (write-byte (arithmetic-shift waiting (- 8 waiting-bits))
- out)
- (let ([waiting-bits (- waiting-bits 8)])
- (loop (bitwise-and waiting (sub1 (arithmetic-shift 1 waiting-bits)))
- waiting-bits)))
- (let* ([c0 (read-byte in)]
- [c (if (eof-object? c0) (char->integer #\=) c0)]
- [v (vector-ref base64-digit c)])
- (cond
- [v (loop (+ (arithmetic-shift waiting 6) v)
- (+ waiting-bits 6))]
- [(eq? c (char->integer #\=)) (void)] ; done
- [else (loop waiting waiting-bits)])))))
+ (define (base64-filename-safe)
+ (vector-set! base64-digit (char->integer #\-) 62)
+ (vector-set! base64-digit (char->integer #\_) 63)
+ (each-char #\- #\- 62)
+ (each-char #\_ #\_ 63))
+ (define (base64-decode-stream in out)
+ (let loop ([waiting 0][waiting-bits 0])
+ (if (>= waiting-bits 8)
+ (begin
+ (write-byte (arithmetic-shift waiting (- 8 waiting-bits)) out)
+ (let ([waiting-bits (- waiting-bits 8)])
+ (loop (bitwise-and waiting (sub1 (arithmetic-shift 1 waiting-bits)))
+ waiting-bits)))
+ (let* ([c0 (read-byte in)]
+ [c (if (eof-object? c0) (char->integer #\=) c0)]
+ [v (vector-ref base64-digit c)])
+ (cond [v (loop (+ (arithmetic-shift waiting 6) v)
+ (+ waiting-bits 6))]
+ [(eq? c (char->integer #\=)) (void)] ; done
+ [else (loop waiting waiting-bits)])))))
- (define base64-encode-stream
- (case-lambda
- [(in out) (base64-encode-stream in out #"\n")]
- [(in out linesep)
- ;; Process input 3 characters at a time, because 18 bits
- ;; is divisible by both 6 and 8, and 72 (the line length)
- ;; is divisible by 3.
- (let ([three (make-bytes 3)]
- [outc (lambda (n)
- (write-byte (vector-ref digit-base64 n) out))]
- [done (lambda (fill)
- (let loop ([fill fill])
- (unless (zero? fill)
- (write-byte (char->integer #\=) out)
- (loop (sub1 fill))))
- (display linesep out))])
- (let loop ([pos 0])
- (if (= pos 72)
- ; Insert newline
- (begin
- (display linesep out)
- (loop 0))
- ;; Next group of 3
- (let ([n (read-bytes-avail! three in)])
- (cond
- [(eof-object? n)
- (unless (= pos 0)
- (done 0))]
- [(= n 3)
- ;; Easy case:
- (let ([a (bytes-ref three 0)]
- [b (bytes-ref three 1)]
- [c (bytes-ref three 2)])
- (outc (arithmetic-shift a -2))
- (outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
- (arithmetic-shift b -4)))
- (outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
- (arithmetic-shift c -6)))
- (outc (bitwise-and #x3f c))
- (loop (+ pos 4)))]
- [else
- ;; Hard case: n is 1 or 2
- (let ([a (bytes-ref three 0)])
- (outc (arithmetic-shift a -2))
- (let* ([next (if (= n 2)
- (bytes-ref three 1)
- (read-byte in))]
- [b (if (eof-object? next)
- 0
- next)])
- (outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
- (arithmetic-shift b -4)))
- (if (eof-object? next)
- (done 2)
- ;; More to go
- (let* ([next (read-byte in)]
- [c (if (eof-object? next)
- 0
- next)])
- (outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
- (arithmetic-shift c -6)))
- (if (eof-object? next)
- (done 1)
- ;; Finish c, loop
- (begin
- (outc (bitwise-and #x3f c))
- (loop (+ pos 4))))))))])))))]))
+ (define base64-encode-stream
+ (case-lambda
+ [(in out) (base64-encode-stream in out #"\n")]
+ [(in out linesep)
+ ;; Process input 3 characters at a time, because 18 bits
+ ;; is divisible by both 6 and 8, and 72 (the line length)
+ ;; is divisible by 3.
+ (let ([three (make-bytes 3)]
+ [outc (lambda (n)
+ (write-byte (vector-ref digit-base64 n) out))]
+ [done (lambda (fill)
+ (let loop ([fill fill])
+ (unless (zero? fill)
+ (write-byte (char->integer #\=) out)
+ (loop (sub1 fill))))
+ (display linesep out))])
+ (let loop ([pos 0])
+ (if (= pos 72)
+ ;; Insert newline
+ (begin
+ (display linesep out)
+ (loop 0))
+ ;; Next group of 3
+ (let ([n (read-bytes-avail! three in)])
+ (cond
+ [(eof-object? n)
+ (unless (= pos 0) (done 0))]
+ [(= n 3)
+ ;; Easy case:
+ (let ([a (bytes-ref three 0)]
+ [b (bytes-ref three 1)]
+ [c (bytes-ref three 2)])
+ (outc (arithmetic-shift a -2))
+ (outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
+ (arithmetic-shift b -4)))
+ (outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
+ (arithmetic-shift c -6)))
+ (outc (bitwise-and #x3f c))
+ (loop (+ pos 4)))]
+ [else
+ ;; Hard case: n is 1 or 2
+ (let ([a (bytes-ref three 0)])
+ (outc (arithmetic-shift a -2))
+ (let* ([next (if (= n 2)
+ (bytes-ref three 1)
+ (read-byte in))]
+ [b (if (eof-object? next)
+ 0
+ next)])
+ (outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
+ (arithmetic-shift b -4)))
+ (if (eof-object? next)
+ (done 2)
+ ;; More to go
+ (let* ([next (read-byte in)]
+ [c (if (eof-object? next)
+ 0
+ next)])
+ (outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
+ (arithmetic-shift c -6)))
+ (if (eof-object? next)
+ (done 1)
+ ;; Finish c, loop
+ (begin
+ (outc (bitwise-and #x3f c))
+ (loop (+ pos 4))))))))])))))]))
- (define (base64-decode src)
- (let ([s (open-output-bytes)])
- (base64-decode-stream (open-input-bytes src) s)
- (get-output-bytes s)))
+ (define (base64-decode src)
+ (let ([s (open-output-bytes)])
+ (base64-decode-stream (open-input-bytes src) s)
+ (get-output-bytes s)))
- (define (base64-encode src)
- (let ([s (open-output-bytes)])
- (base64-encode-stream (open-input-bytes src) s
- (bytes 13 10))
- (get-output-bytes s))))
+ (define (base64-encode src)
+ (let ([s (open-output-bytes)])
+ (base64-encode-stream (open-input-bytes src) s (bytes 13 10))
+ (get-output-bytes s))))
diff --git a/collects/net/cgi-sig.ss b/collects/net/cgi-sig.ss
index 61c9528..9f979dd 100644
--- a/collects/net/cgi-sig.ss
+++ b/collects/net/cgi-sig.ss
@@ -3,7 +3,7 @@
(struct cgi-error ())
(struct incomplete-%-suffix (chars))
(struct invalid-%-suffix (char))
-
+
;; -- cgi methods --
get-bindings
get-bindings/post
@@ -15,9 +15,8 @@
extract-bindings
extract-binding/single
get-cgi-method
-
+
;; -- general HTML utilities --
string->html
generate-link-text
)
-
diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss
index 58c7600..f754d21 100644
--- a/collects/net/cgi-unit.ss
+++ b/collects/net/cgi-unit.ss
@@ -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
- [(#\<) "<"]
- [(#\>) ">"]
- [(#\&) "&"]
- [else (string c)]))
- (string->list s))))
+ (define (string->html s)
+ (apply string-append
+ (map (lambda (c)
+ (case c
+ [(#\<) "<"]
+ [(#\>) ">"]
+ [(#\&) "&"]
+ [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"
- ""
- ""
- ""
- ""
- ,(sa "" title "")
- ""
- ""
- ,(sa "")
- ""
- ,@body-lines
- ""
- ""
- "")))))
+ (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"
+ ""
+ ""
+ ""
+ ""
+ ,(sa "" title "")
+ ""
+ ""
+ ,(sa "")
+ ""
+ ,@body-lines
+ ""
+ ""
+ "")))))
- ;; 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) ->
+ (define (generate-error-output error-message-lines)
+ (generate-html-output "Internal Error" error-message-lines)
+ (exit))
- ;; generate-error-output : list (html-string) ->
- (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)
+ `(""
+ ,@(map (lambda (bind)
+ (string-append (symbol->string (car bind))
+ " --> "
+ (cdr bind)
+ "
"))
+ bindings)
+ ""))
- ;; bindings-as-html : bindings -> list (html-string)
- ;; -- formats name-value bindings as HTML appropriate for displaying
- (define (bindings-as-html bindings)
- `(""
- ,@(map (lambda (bind)
- (string-append (symbol->string (car bind))
- " --> "
- (cdr bind)
- "
"))
- 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-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':
" 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:
"
+ 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':
" 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:
"
- 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 "" anchor-text ""))
-
- )
+ ;; generate-link-text : string x html-string -> html-string
+ (define (generate-link-text url anchor-text)
+ (string-append "" anchor-text ""))
+ )
diff --git a/collects/net/cookie-sig.ss b/collects/net/cookie-sig.ss
index dc93601..0bb5576 100644
--- a/collects/net/cookie-sig.ss
+++ b/collects/net/cookie-sig.ss
@@ -1,5 +1,4 @@
(module cookie-sig (lib "a-signature.ss")
-
set-cookie
cookie:add-comment
cookie:add-domain
diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss
index 6f1f059..09a8909 100644
--- a/collects/net/cookie-unit.ss
+++ b/collects/net/cookie-unit.ss
@@ -2,7 +2,7 @@
;;; ---- HTTP cookies library
;;; Time-stamp: <03/04/25 10:50:05 noel>
;;;
-;;; Copyright (C) 2002 by Francisco Solsona.
+;;; Copyright (C) 2002 by Francisco Solsona.
;;;
;;; This file is part of net.
@@ -49,9 +49,9 @@
(module cookie-unit (lib "a-unit.ss")
(require (lib "etc.ss")
- (lib "list.ss")
- (lib "string.ss" "srfi" "13")
- (lib "char-set.ss" "srfi" "14")
+ (lib "list.ss")
+ (lib "string.ss" "srfi" "13")
+ (lib "char-set.ss" "srfi" "14")
"cookie-sig.ss")
(import)
@@ -60,6 +60,14 @@
(define-struct cookie (name value comment domain max-age path secure version))
(define-struct (cookie-error exn:fail) ())
+ ;; cookie-error : string args ... -> raises a cookie-error exception
+ ;; constructs a cookie-error struct from the given error message
+ ;; (added to fix exceptions-must-take-immutable-strings bug)
+ (define (cookie-error fmt . args)
+ (make-cookie-error
+ (string->immutable-string (apply format fmt args))
+ (current-continuation-marks)))
+
;; The syntax for the Set-Cookie response header is
;; set-cookie = "Set-Cookie:" cookies
;; cookies = 1#cookie
@@ -67,24 +75,23 @@
;; NAME = attr
;; VALUE = value
;; cookie-av = "Comment" "=" value
- ;; | "Domain" "=" value
- ;; | "Max-Age" "=" value
- ;; | "Path" "=" value
- ;; | "Secure"
- ;; | "Version" "=" 1*DIGIT
- (define set-cookie
- (lambda (name pre-value)
- (let ([value (to-rfc2109:value pre-value)])
- (unless (rfc2068:token? name)
- (raise (build-cookie-error (format "Invalid cookie name: ~a / ~a" name value))))
- (make-cookie name value
- #f;; comment
- #f;; current domain
- #f;; at the end of session
- #f;; current path
- #f;; normal (non SSL)
- #f;; default version
- ))))
+ ;; | "Domain" "=" value
+ ;; | "Max-Age" "=" value
+ ;; | "Path" "=" value
+ ;; | "Secure"
+ ;; | "Version" "=" 1*DIGIT
+ (define (set-cookie name pre-value)
+ (let ([value (to-rfc2109:value pre-value)])
+ (unless (rfc2068:token? name)
+ (cookie-error "Invalid cookie name: ~a / ~a" name value))
+ (make-cookie name value
+ #f ; comment
+ #f ; current domain
+ #f ; at the end of session
+ #f ; current path
+ #f ; normal (non SSL)
+ #f ; default version
+ )))
;;!
;;
@@ -94,73 +101,65 @@
;;
;; Formats the cookie contents in a string ready to be appended to a
;; "Set-Cookie: " header, and sent to a client (browser).
- (define print-cookie
- (lambda (cookie)
- (unless (cookie? cookie)
- (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
- (string-join
- (filter (lambda (s)
- (not (string-null? s)))
- (list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
- (let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) ""))
- (let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) ""))
- (let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) ""))
- (let ((p (cookie-path cookie))) (if p (format "Path=~a" p) ""))
- (let ((s (cookie-secure cookie))) (if s "Secure" ""))
- (let ((v (cookie-version cookie))) (format "Version=~a" (if v v 1)))))
- "; ")))
+ (define (print-cookie cookie)
+ (unless (cookie? cookie)
+ (cookie-error "Cookie expected, received: ~a" cookie))
+ (string-join
+ (filter (lambda (s) (not (string-null? s)))
+ (list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
+ (let ([c (cookie-comment cookie)]) (if c (format "Comment=~a" c) ""))
+ (let ([d (cookie-domain cookie)]) (if d (format "Domain=~a" d) ""))
+ (let ([age (cookie-max-age cookie)]) (if age (format "Max-Age=~a" age) ""))
+ (let ([p (cookie-path cookie)]) (if p (format "Path=~a" p) ""))
+ (let ([s (cookie-secure cookie)]) (if s "Secure" ""))
+ (let ([v (cookie-version cookie)]) (format "Version=~a" (if v v 1)))))
+ "; "))
- (define cookie:add-comment
- (lambda (cookie pre-comment)
- (let ([comment (to-rfc2109:value pre-comment)])
- (unless (cookie? cookie)
- (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
- (set-cookie-comment! cookie comment)
- cookie)))
-
- (define cookie:add-domain
- (lambda (cookie domain)
- (unless (valid-domain? domain)
- (raise (build-cookie-error (format "Invalid domain: ~a" domain))))
+ (define (cookie:add-comment cookie pre-comment)
+ (let ([comment (to-rfc2109:value pre-comment)])
(unless (cookie? cookie)
- (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
- (set-cookie-domain! cookie domain)
+ (cookie-error "Cookie expected, received: ~a" cookie))
+ (set-cookie-comment! cookie comment)
cookie))
- (define cookie:add-max-age
- (lambda (cookie seconds)
- (unless (and (integer? seconds) (not (negative? seconds)))
- (raise (build-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds))))
+ (define (cookie:add-domain cookie domain)
+ (unless (valid-domain? domain)
+ (cookie-error "Invalid domain: ~a" domain))
+ (unless (cookie? cookie)
+ (cookie-error "Cookie expected, received: ~a" cookie))
+ (set-cookie-domain! cookie domain)
+ cookie)
+
+ (define (cookie:add-max-age cookie seconds)
+ (unless (and (integer? seconds) (not (negative? seconds)))
+ (cookie-error "Invalid Max-Age for cookie: ~a" seconds))
+ (unless (cookie? cookie)
+ (cookie-error "Cookie expected, received: ~a" cookie))
+ (set-cookie-max-age! cookie seconds)
+ cookie)
+
+ (define (cookie:add-path cookie pre-path)
+ (let ([path (to-rfc2109:value pre-path)])
(unless (cookie? cookie)
- (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
- (set-cookie-max-age! cookie seconds)
+ (cookie-error "Cookie expected, received: ~a" cookie))
+ (set-cookie-path! cookie path)
cookie))
- (define cookie:add-path
- (lambda (cookie pre-path)
- (let ([path (to-rfc2109:value pre-path)])
- (unless (cookie? cookie)
- (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
- (set-cookie-path! cookie path)
- cookie)))
+ (define (cookie:secure cookie secure?)
+ (unless (boolean? secure?)
+ (cookie-error "Invalid argument (boolean expected), received: ~a" secure?))
+ (unless (cookie? cookie)
+ (cookie-error "Cookie expected, received: ~a" cookie))
+ (set-cookie-secure! cookie secure?)
+ cookie)
- (define cookie:secure
- (lambda (cookie secure?)
- (unless (boolean? secure?)
- (raise (build-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?))))
- (unless (cookie? cookie)
- (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
- (set-cookie-secure! cookie secure?)
- cookie))
-
- (define cookie:version
- (lambda (cookie version)
- (unless (integer? version)
- (raise (build-cookie-error (format "Unsupported version: ~a" version))))
- (unless (cookie? cookie)
- (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
- (set-cookie-version! cookie version)
- cookie))
+ (define (cookie:version cookie version)
+ (unless (integer? version)
+ (cookie-error "Unsupported version: ~a" version))
+ (unless (cookie? cookie)
+ (cookie-error "Cookie expected, received: ~a" cookie))
+ (set-cookie-version! cookie version)
+ cookie)
;; Parsing the Cookie header:
@@ -177,27 +176,26 @@
;;
;; Auxiliar procedure that returns all values associated with
;; `name' in the association list (cookies).
- (define get-all-results
- (lambda (name cookies)
- (let loop ((c cookies))
- (cond ((null? c) ())
- (else
- (let ((pair (car c)))
- (if (string=? name (car pair))
- ;; found an instance of cookie named `name'
- (cons (cadr pair) (loop (cdr c)))
- (loop (cdr c)))))))))
+ (define (get-all-results name cookies)
+ (let loop ([c cookies])
+ (if (null? c)
+ '()
+ (let ([pair (car c)])
+ (if (string=? name (car pair))
+ ;; found an instance of cookie named `name'
+ (cons (cadr pair) (loop (cdr c)))
+ (loop (cdr c)))))))
- ;; which tipically looks like: (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
- ;; note that it can be multi-valued: `test1' has values: "1", and "20".
- ;; Of course, in the same spirit, we only receive the "string content".
- (define get-cookie
- (lambda (name cookies)
- (let ((cookies (map (lambda (p)
- (map string-trim-both
- (string-tokenize p char-set:all-but=)))
- (string-tokenize cookies char-set:all-but-semicolon))))
- (get-all-results name cookies))))
+ ;; which typically looks like:
+ ;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
+ ;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
+ ;; course, in the same spirit, we only receive the "string content".
+ (define (get-cookie name cookies)
+ (let ([cookies (map (lambda (p)
+ (map string-trim-both
+ (string-tokenize p char-set:all-but=)))
+ (string-tokenize cookies char-set:all-but-semicolon))])
+ (get-all-results name cookies)))
;;!
;;
@@ -207,11 +205,9 @@
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
;;
;; Returns the first name associated with the cookie named `name', if any, or #f.
- (define get-cookie/single
- (lambda (name cookies)
- (let ((cookies (get-cookie name cookies)))
- (and (not (null? cookies))
- (car cookies)))))
+ (define (get-cookie/single name cookies)
+ (let ([cookies (get-cookie name cookies)])
+ (and (not (null? cookies)) (car cookies))))
;;;;;
@@ -221,9 +217,9 @@
;; token = 1*
;;
;; tspecials = "(" | ")" | "<" | ">" | "@"
- ;; | "," | ";" | ":" | "\" | <">
- ;; | "/" | "[" | "]" | "?" | "="
- ;; | "{" | "}" | SP | HT
+ ;; | "," | ";" | ":" | "\" | <">
+ ;; | "/" | "[" | "]" | "?" | "="
+ ;; | "{" | "}" | SP | HT
(define char-set:tspecials
(char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
char-set:whitespace
@@ -232,13 +228,14 @@
(define char-set:control
(char-set-union char-set:iso-control
(char-set (integer->char 127))));; DEL
- (define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control))
+ (define char-set:token
+ (char-set-difference char-set:ascii char-set:tspecials char-set:control))
;; token? : string -> boolean
;;
;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
- (define rfc2068:token?
- (lambda (s) (string-every char-set:token s)))
+ (define (rfc2068:token? s)
+ (string-every char-set:token s))
;;!
;;
@@ -256,29 +253,30 @@
;; quoted-pair = "\" CHAR
;;
;; implementation note: I have chosen to use a regular expression rather than
- ;; a character set for this definition because of two dependencies: CRLF must appear
- ;; as a block to be legal, and " may only appear as \"
- (define rfc2068:quoted-string?
- (lambda (s)
- (if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s)
- s
- #f)))
+ ;; a character set for this definition because of two dependencies: CRLF must
+ ;; appear as a block to be legal, and " may only appear as \"
+ (define (rfc2068:quoted-string? s)
+ (if (regexp-match
+ #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
+ s)
+ s
+ #f))
;; value: token | quoted-string
(define (rfc2109:value? s)
(or (rfc2068:token? s) (rfc2068:quoted-string? s)))
;; convert-to-quoted : string -> quoted-string?
- ;; takes the given string as a particular message, and converts the given string to that
- ;; representatation
+ ;; takes the given string as a particular message, and converts the given
+ ;; string to that representatation
(define (convert-to-quoted str)
(string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
- ;; string -> rfc2109:value?
+ ;; string -> rfc2109:value?
(define (to-rfc2109:value s)
(cond
- [(not (string? s))
- (raise (build-cookie-error (format "Expected string, given: ~e" s)))]
+ [(not (string? s))
+ (cookie-error "Expected string, given: ~e" s)]
;; for backwards compatibility, just use the given string if it will work
[(rfc2068:token? s) s]
@@ -289,9 +287,7 @@
[(rfc2068:quoted-string? (convert-to-quoted s))
=> (λ (x) x)]
[else
- (raise
- (build-cookie-error
- (format "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)))]))
+ (cookie-error "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
;;!
;;
@@ -304,7 +300,7 @@
(define cookie-string?
(opt-lambda (s (value? #t))
(unless (string? s)
- (raise (build-cookie-error (format "String expected, received: ~a" s))))
+ (cookie-error "String expected, received: ~a" s))
(if value?
(rfc2109:value? s)
;; name: token
@@ -312,31 +308,21 @@
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
(define char-set:hostname
- (let ((a-z-lowercase (ucs-range->char-set #x61 #x7B))
- (a-z-uppercase (ucs-range->char-set #x41 #x5B)))
+ (let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
+ [a-z-uppercase (ucs-range->char-set #x41 #x5B)])
(char-set-adjoin!
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
- #\. )))
+ #\.)))
- (define valid-domain?
- (lambda (dom)
- (and
- ;; Domain must start with a dot (.)
- (string=? (string-take dom 1) ".")
- ;; The rest are tokens-like strings separated by dots
- (string-every char-set:hostname dom)
- (<= (string-length dom) 76))))
+ (define (valid-domain? dom)
+ (and ;; Domain must start with a dot (.)
+ (string=? (string-take dom 1) ".")
+ ;; The rest are tokens-like strings separated by dots
+ (string-every char-set:hostname dom)
+ (<= (string-length dom) 76)))
(define (valid-path? v)
- (and (string? v)
- (rfc2109:value? v)))
-
- ;; build-cookie-error : string -> cookie-error
- ;; constructs a cookie-error struct from the given error message
- ;; (added to fix exceptions-must-take-immutable-strings bug)
- (define (build-cookie-error msg)
- (make-cookie-error (string->immutable-string msg)
- (current-continuation-marks)))
+ (and (string? v) (rfc2109:value? v)))
)
diff --git a/collects/net/dns-sig.ss b/collects/net/dns-sig.ss
index 02407eb..f0fe451 100644
--- a/collects/net/dns-sig.ss
+++ b/collects/net/dns-sig.ss
@@ -3,4 +3,3 @@
dns-get-name
dns-get-mail-exchanger
dns-find-nameserver)
-
diff --git a/collects/net/dns-unit.ss b/collects/net/dns-unit.ss
index 7ff9760..0791b43 100644
--- a/collects/net/dns-unit.ss
+++ b/collects/net/dns-unit.ss
@@ -1,342 +1,321 @@
(module dns-unit (lib "a-unit.ss")
- (require (lib "list.ss")
- (lib "process.ss")
- "dns-sig.ss")
-
+ (require (lib "list.ss") (lib "process.ss") "dns-sig.ss")
(import)
(export dns^)
- ;; UDP retry timeout:
- (define INIT-TIMEOUT 50)
+ ;; UDP retry timeout:
+ (define INIT-TIMEOUT 50)
- (define types
- '((a 1)
- (ns 2)
- (md 3)
- (mf 4)
- (cname 5)
- (soa 6)
- (mb 7)
- (mg 8)
- (mr 9)
- (null 10)
- (wks 11)
- (ptr 12)
- (hinfo 13)
- (minfo 14)
- (mx 15)
- (txt 16)))
+ (define types
+ '((a 1)
+ (ns 2)
+ (md 3)
+ (mf 4)
+ (cname 5)
+ (soa 6)
+ (mb 7)
+ (mg 8)
+ (mr 9)
+ (null 10)
+ (wks 11)
+ (ptr 12)
+ (hinfo 13)
+ (minfo 14)
+ (mx 15)
+ (txt 16)))
- (define classes
- '((in 1)
- (cs 2)
- (ch 3)
- (hs 4)))
+ (define classes
+ '((in 1)
+ (cs 2)
+ (ch 3)
+ (hs 4)))
- (define (cossa i l)
- (cond
- [(null? l) #f]
- [(equal? (cadar l) i)
- (car l)]
- [else (cossa i (cdr l))]))
-
+ (define (cossa i l)
+ (cond [(null? l) #f]
+ [(equal? (cadar l) i) (car l)]
+ [else (cossa i (cdr l))]))
- (define (number->octet-pair n)
- (list (arithmetic-shift n -8)
- (modulo n 256)))
+ (define (number->octet-pair n)
+ (list (arithmetic-shift n -8)
+ (modulo n 256)))
- (define (octet-pair->number a b)
- (+ (arithmetic-shift a 8)
- b))
+ (define (octet-pair->number a b)
+ (+ (arithmetic-shift a 8) b))
- (define (octet-quad->number a b c d)
- (+ (arithmetic-shift a 24)
- (arithmetic-shift b 16)
- (arithmetic-shift c 8)
- d))
+ (define (octet-quad->number a b c d)
+ (+ (arithmetic-shift a 24)
+ (arithmetic-shift b 16)
+ (arithmetic-shift c 8)
+ d))
- (define (name->octets s)
- (let ([do-one (lambda (s)
- (cons
- (bytes-length s)
- (bytes->list s)))])
- (let loop ([s s])
- (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
- (if m
- (append
- (do-one (cadr m))
- (loop (caddr m)))
- (append
- (do-one s)
- (list 0)))))))
+ (define (name->octets s)
+ (let ([do-one (lambda (s)
+ (cons (bytes-length s) (bytes->list s)))])
+ (let loop ([s s])
+ (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)])
+ (if m
+ (append (do-one (cadr m)) (loop (caddr m)))
+ (append (do-one s) (list 0)))))))
- (define (make-std-query-header id question-count)
- (append
- (number->octet-pair id)
- (list 1 0) ; Opcode & flags (recusive flag set)
- (number->octet-pair question-count)
- (number->octet-pair 0)
- (number->octet-pair 0)
- (number->octet-pair 0)))
+ (define (make-std-query-header id question-count)
+ (append (number->octet-pair id)
+ (list 1 0) ; Opcode & flags (recusive flag set)
+ (number->octet-pair question-count)
+ (number->octet-pair 0)
+ (number->octet-pair 0)
+ (number->octet-pair 0)))
- (define (make-query id name type class)
- (append
- (make-std-query-header id 1)
- (name->octets name)
- (number->octet-pair (cadr (assoc type types)))
- (number->octet-pair (cadr (assoc class classes)))))
+ (define (make-query id name type class)
+ (append (make-std-query-header id 1)
+ (name->octets name)
+ (number->octet-pair (cadr (assoc type types)))
+ (number->octet-pair (cadr (assoc class classes)))))
- (define (add-size-tag m)
- (append (number->octet-pair (length m)) m))
+ (define (add-size-tag m)
+ (append (number->octet-pair (length m)) m))
- (define (rr-data rr)
- (cadddr (cdr rr)))
+ (define (rr-data rr)
+ (cadddr (cdr rr)))
- (define (rr-type rr)
- (cadr rr))
+ (define (rr-type rr)
+ (cadr rr))
- (define (rr-name rr)
- (car rr))
+ (define (rr-name rr)
+ (car rr))
- (define (parse-name start reply)
- (let ([v (car start)])
- (cond
- [(zero? v)
- ;; End of name
- (values #f (cdr start))]
- [(zero? (bitwise-and #xc0 v))
- ;; Normal label
- (let loop ([len v][start (cdr start)][accum null])
- (cond
- [(zero? len)
- (let-values ([(s start) (parse-name start reply)])
- (let ([s0 (list->bytes (reverse! accum))])
- (values (if s
- (bytes-append s0 #"." s)
- s0)
- start)))]
- [else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
- [else
- ;; Compression offset
- (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
- (cadr start))])
- (let-values ([(s ignore-start) (parse-name (list-tail reply offset) reply)])
- (values s (cddr start))))])))
+ (define (parse-name start reply)
+ (let ([v (car start)])
+ (cond
+ [(zero? v)
+ ;; End of name
+ (values #f (cdr start))]
+ [(zero? (bitwise-and #xc0 v))
+ ;; Normal label
+ (let loop ([len v][start (cdr start)][accum null])
+ (cond
+ [(zero? len)
+ (let-values ([(s start) (parse-name start reply)])
+ (let ([s0 (list->bytes (reverse! accum))])
+ (values (if s (bytes-append s0 #"." s) s0)
+ start)))]
+ [else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
+ [else
+ ;; Compression offset
+ (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
+ (cadr start))])
+ (let-values ([(s ignore-start)
+ (parse-name (list-tail reply offset) reply)])
+ (values s (cddr start))))])))
- (define (parse-rr start reply)
- (let-values ([(name start) (parse-name start reply)])
- (let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
- [start (cddr start)])
- (let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
- [start (cddr start)])
- (let ([ttl (octet-quad->number (car start) (cadr start)
- (caddr start) (cadddr start))]
- [start (cddddr start)])
- (let ([len (octet-pair->number (car start) (cadr start))]
- [start (cddr start)])
- ; Extract next len bytes for data:
- (let loop ([len len][start start][accum null])
- (if (zero? len)
- (values (list name type class ttl (reverse! accum))
- start)
- (loop (sub1 len) (cdr start) (cons (car start) accum))))))))))
+ (define (parse-rr start reply)
+ (let-values ([(name start) (parse-name start reply)])
+ (let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
+ types))]
+ [start (cddr start)]
+ ;;
+ [class (car (cossa (octet-pair->number (car start) (cadr start))
+ classes))]
+ [start (cddr start)]
+ ;;
+ [ttl (octet-quad->number (car start) (cadr start)
+ (caddr start) (cadddr start))]
+ [start (cddddr start)]
+ ;;
+ [len (octet-pair->number (car start) (cadr start))]
+ [start (cddr start)])
+ ;; Extract next len bytes for data:
+ (let loop ([len len] [start start] [accum null])
+ (if (zero? len)
+ (values (list name type class ttl (reverse! accum))
+ start)
+ (loop (sub1 len) (cdr start) (cons (car start) accum)))))))
- (define (parse-ques start reply)
- (let-values ([(name start) (parse-name start reply)])
- (let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
- [start (cddr start)])
- (let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
- [start (cddr start)])
- (values (list name type class) start)))))
+ (define (parse-ques start reply)
+ (let-values ([(name start) (parse-name start reply)])
+ (let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
+ types))]
+ [start (cddr start)]
+ ;;
+ [class (car (cossa (octet-pair->number (car start) (cadr start))
+ classes))]
+ [start (cddr start)])
+ (values (list name type class) start))))
- (define (parse-n parse start reply n)
- (let loop ([n n][start start][accum null])
- (if (zero? n)
- (values (reverse! accum) start)
- (let-values ([(rr start) (parse start reply)])
- (loop (sub1 n) start (cons rr accum))))))
+ (define (parse-n parse start reply n)
+ (let loop ([n n][start start][accum null])
+ (if (zero? n)
+ (values (reverse! accum) start)
+ (let-values ([(rr start) (parse start reply)])
+ (loop (sub1 n) start (cons rr accum))))))
- (define (dns-query nameserver addr type class)
- (unless (assoc type types)
- (raise-type-error 'dns-query "DNS query type" type))
- (unless (assoc class classes)
- (raise-type-error 'dns-query "DNS query class" class))
+ (define (dns-query nameserver addr type class)
+ (unless (assoc type types)
+ (raise-type-error 'dns-query "DNS query type" type))
+ (unless (assoc class classes)
+ (raise-type-error 'dns-query "DNS query class" class))
- (let* ([query (make-query (random 256) (string->bytes/latin-1 addr) type class)]
- [udp (udp-open-socket)]
- [reply
- (dynamic-wind
- void
-
- (lambda ()
- (let ([s (make-bytes 512)])
- (let retry ([timeout INIT-TIMEOUT])
- (udp-send-to udp nameserver 53 (list->bytes query))
-
- (sync
- (handle-evt
- (udp-receive!-evt udp s)
- (lambda (r)
- (bytes->list (subbytes s 0 (car r)))))
- (handle-evt
- (alarm-evt (+ (current-inexact-milliseconds)
- timeout))
- (lambda (v)
- (retry (* timeout 2))))))))
-
- (lambda ()
- (udp-close udp)))])
+ (let* ([query (make-query (random 256) (string->bytes/latin-1 addr)
+ type class)]
+ [udp (udp-open-socket)]
+ [reply
+ (dynamic-wind
+ void
+ (lambda ()
+ (let ([s (make-bytes 512)])
+ (let retry ([timeout INIT-TIMEOUT])
+ (udp-send-to udp nameserver 53 (list->bytes query))
+ (sync (handle-evt
+ (udp-receive!-evt udp s)
+ (lambda (r)
+ (bytes->list (subbytes s 0 (car r)))))
+ (handle-evt
+ (alarm-evt (+ (current-inexact-milliseconds)
+ timeout))
+ (lambda (v)
+ (retry (* timeout 2))))))))
+ (lambda () (udp-close udp)))])
- ; First two bytes must match sent message id:
- (unless (and (= (car reply) (car query))
- (= (cadr reply) (cadr query)))
- (error 'dns-query "bad reply id from server"))
+ ;; First two bytes must match sent message id:
+ (unless (and (= (car reply) (car query))
+ (= (cadr reply) (cadr query)))
+ (error 'dns-query "bad reply id from server"))
- (let ([v0 (caddr reply)]
- [v1 (cadddr reply)])
- ; Check for error code:
- (let ([rcode (bitwise-and #xf v1)])
- (unless (zero? rcode)
- (error 'dns-query "error from server: ~a"
- (case rcode
- [(1) "format error"]
- [(2) "server failure"]
- [(3) "name error"]
- [(4) "not implemented"]
- [(5) "refused"]))))
-
- (let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
- [an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
- [ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
- [ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
-
- (let ([start (list-tail reply 12)])
- (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
- [(ans start) (parse-n parse-rr start reply an-count)]
- [(nss start) (parse-n parse-rr start reply ns-count)]
- [(ars start) (parse-n parse-rr start reply ar-count)])
- (unless (null? start)
- (error 'dns-query "error parsing server reply"))
- (values (positive? (bitwise-and #x4 v0))
- qds ans nss ars reply)))))))
+ (let ([v0 (caddr reply)]
+ [v1 (cadddr reply)])
+ ;; Check for error code:
+ (let ([rcode (bitwise-and #xf v1)])
+ (unless (zero? rcode)
+ (error 'dns-query "error from server: ~a"
+ (case rcode
+ [(1) "format error"]
+ [(2) "server failure"]
+ [(3) "name error"]
+ [(4) "not implemented"]
+ [(5) "refused"]))))
- (define cache (make-hash-table))
- (define (dns-query/cache nameserver addr type class)
- (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
- (let ([v (hash-table-get cache key (lambda () #f))])
- (if v
- (apply values v)
- (let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
- (hash-table-put! cache key (list auth? qds ans nss ars reply))
- (values auth? qds ans nss ars reply))))))
+ (let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
+ [an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
+ [ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
+ [ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
- (define (ip->string s)
- (format "~a.~a.~a.~a"
- (list-ref s 0)
- (list-ref s 1)
- (list-ref s 2)
- (list-ref s 3)))
+ (let ([start (list-tail reply 12)])
+ (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
+ [(ans start) (parse-n parse-rr start reply an-count)]
+ [(nss start) (parse-n parse-rr start reply ns-count)]
+ [(ars start) (parse-n parse-rr start reply ar-count)])
+ (unless (null? start)
+ (error 'dns-query "error parsing server reply"))
+ (values (positive? (bitwise-and #x4 v0))
+ qds ans nss ars reply)))))))
- (define (try-forwarding k nameserver)
- (let loop ([nameserver nameserver][tried (list nameserver)])
- ; Normally the recusion is done for us, but it's technically optional
- (let-values ([(v ars auth?) (k nameserver)])
- (or v
- (and (not auth?)
- (let* ([ns (ormap
- (lambda (ar)
- (and (eq? (rr-type ar) 'a)
- (ip->string (rr-data ar))))
- ars)])
- (and ns
- (not (member ns tried))
- (loop ns (cons ns tried)))))))))
+ (define cache (make-hash-table))
+ (define (dns-query/cache nameserver addr type class)
+ (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
+ (let ([v (hash-table-get cache key (lambda () #f))])
+ (if v
+ (apply values v)
+ (let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
+ (hash-table-put! cache key (list auth? qds ans nss ars reply))
+ (values auth? qds ans nss ars reply))))))
+
+ (define (ip->string s)
+ (format "~a.~a.~a.~a"
+ (list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3)))
+
+ (define (try-forwarding k nameserver)
+ (let loop ([nameserver nameserver][tried (list nameserver)])
+ ;; Normally the recusion is done for us, but it's technically optional
+ (let-values ([(v ars auth?) (k nameserver)])
+ (or v
+ (and (not auth?)
+ (let* ([ns (ormap (lambda (ar)
+ (and (eq? (rr-type ar) 'a)
+ (ip->string (rr-data ar))))
+ ars)])
+ (and ns
+ (not (member ns tried))
+ (loop ns (cons ns tried)))))))))
+
+ (define (ip->in-addr.arpa ip)
+ (let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$"
+ ip)])
+ (format "~a.~a.~a.~a.in-addr.arpa"
+ (list-ref result 4)
+ (list-ref result 3)
+ (list-ref result 2)
+ (list-ref result 1))))
+
+ (define (get-ptr-list-from-ans ans)
+ (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr))
+ ans))
+
+ (define (dns-get-name nameserver ip)
+ (or (try-forwarding
+ (lambda (nameserver)
+ (let-values ([(auth? qds ans nss ars reply)
+ (dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
+ (values (and (positive? (length (get-ptr-list-from-ans ans)))
+ (let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
+ (let-values ([(name null) (parse-name s reply)])
+ (bytes->string/latin-1 name))))
+ ars auth?)))
+ nameserver)
+ (error 'dns-get-name "bad ip address")))
+
+ (define (get-a-list-from-ans ans)
+ (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
+ ans))
- (define ip->in-addr.arpa
- (lambda (ip)
- (let ((result (regexp-match "([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)" ip)))
- (format "~a.~a.~a.~a.in-addr.arpa"
- (list-ref result 4)
- (list-ref result 3)
- (list-ref result 2)
- (list-ref result 1)))))
-
- (define get-ptr-list-from-ans
- (lambda (ans)
- (filter (lambda (ans-entry)
- (eq? (list-ref ans-entry 1) 'ptr))
- ans)))
-
- (define dns-get-name
- (lambda (nameserver ip)
- (or (try-forwarding
- (lambda (nameserver)
- (let-values ([(auth? qds ans nss ars reply)
- (dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)])
- (values (and (positive? (length (get-ptr-list-from-ans ans)))
- (let ([s (rr-data (car (get-ptr-list-from-ans ans)))])
- (let-values (((name null) (parse-name s reply)))
- (bytes->string/latin-1 name))))
- ars auth?)))
- nameserver)
- (error 'dns-get-name "bad ip address"))))
-
- (define get-a-list-from-ans
- (lambda (ans)
- (filter (lambda (ans-entry)
- (eq? (list-ref ans-entry 1) 'a))
- ans)))
-
(define (dns-get-address nameserver addr)
(or (try-forwarding
- (lambda (nameserver)
- (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
- (values (and (positive? (length (get-a-list-from-ans ans)))
- (let ([s (rr-data (car (get-a-list-from-ans ans)))])
- (ip->string s)))
- ars auth?)))
- nameserver)
- (error 'dns-get-address "bad address")))
+ (lambda (nameserver)
+ (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
+ (values (and (positive? (length (get-a-list-from-ans ans)))
+ (let ([s (rr-data (car (get-a-list-from-ans ans)))])
+ (ip->string s)))
+ ars auth?)))
+ nameserver)
+ (error 'dns-get-address "bad address")))
(define (dns-get-mail-exchanger nameserver addr)
(or (try-forwarding
- (lambda (nameserver)
- (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
- (values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
- (cond
- [(null? ans) (or exchanger
- ;; Does 'soa mean that the input address is fine?
- (and (ormap
- (lambda (ns) (eq? (rr-type ns) 'soa))
- nss)
- addr))]
- [else
- (let ([d (rr-data (car ans))])
- (let ([pref (octet-pair->number (car d) (cadr d))])
- (if (< pref best-pref)
- (let-values ([(name start) (parse-name (cddr d) reply)])
- (loop (cdr ans) pref name))
- (loop (cdr ans) best-pref exchanger))))]))
- ars auth?)))
- nameserver)
- (error 'dns-get-mail-exchanger "bad address")))
+ (lambda (nameserver)
+ (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
+ (values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
+ (cond
+ [(null? ans)
+ (or exchanger
+ ;; Does 'soa mean that the input address is fine?
+ (and (ormap (lambda (ns) (eq? (rr-type ns) 'soa))
+ nss)
+ addr))]
+ [else
+ (let ([d (rr-data (car ans))])
+ (let ([pref (octet-pair->number (car d) (cadr d))])
+ (if (< pref best-pref)
+ (let-values ([(name start) (parse-name (cddr d) reply)])
+ (loop (cdr ans) pref name))
+ (loop (cdr ans) best-pref exchanger))))]))
+ ars auth?)))
+ nameserver)
+ (error 'dns-get-mail-exchanger "bad address")))
(define (dns-find-nameserver)
(case (system-type)
[(unix macosx)
(with-handlers ([void (lambda (x) #f)])
- (with-input-from-file "/etc/resolv.conf"
- (lambda ()
- (let loop ()
- (let ([l (read-line)])
- (or (and (string? l)
- (let ([m (regexp-match
- #rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
- l)])
- (and m (cadr m))))
- (and (not (eof-object? l))
- (loop))))))))]
+ (with-input-from-file "/etc/resolv.conf"
+ (lambda ()
+ (let loop ()
+ (let ([l (read-line)])
+ (or (and (string? l)
+ (let ([m (regexp-match
+ #rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)"
+ l)])
+ (and m (cadr m))))
+ (and (not (eof-object? l))
+ (loop))))))))]
[(windows)
(let ([nslookup (find-executable-path "nslookup.exe" #f)])
(and nslookup
@@ -362,4 +341,3 @@
=> (lambda (m) (loop name (cadr m) #f))]
[else (loop name ip #f)]))))))]
[else #f])))
-
diff --git a/collects/net/ftp-sig.ss b/collects/net/ftp-sig.ss
index 2d2712c..c43b9c9 100644
--- a/collects/net/ftp-sig.ss
+++ b/collects/net/ftp-sig.ss
@@ -1,8 +1,7 @@
(module ftp-sig (lib "a-signature.ss")
- ftp-cd
+ ftp-cd
ftp-establish-connection ftp-establish-connection*
- ftp-close-connection
+ ftp-close-connection
ftp-directory-list
ftp-download-file
ftp-make-file-seconds)
-
diff --git a/collects/net/ftp-unit.ss b/collects/net/ftp-unit.ss
index 3c0c5b3..21462ab 100644
--- a/collects/net/ftp-unit.ss
+++ b/collects/net/ftp-unit.ss
@@ -1,215 +1,217 @@
(module ftp-unit (lib "a-unit.ss")
;; Version 0.2
- ;; Version 0.1a
- ;; Micah Flatt
+ ;; Version 0.1a
+ ;; Micah Flatt
;; 06-06-2002
- (require (lib "date.ss")
- (lib "file.ss")
- (lib "port.ss")
- "ftp-sig.ss")
+ (require (lib "date.ss") (lib "file.ss") (lib "port.ss") "ftp-sig.ss")
(import)
(export ftp^)
- ;; opqaue record to represent an FTP connection:
- (define-struct tcp-connection (in out))
-
- (define tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
-
- (define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
- (define re:response-end #rx#"^[0-9][0-9][0-9] ")
+ ;; opqaue record to represent an FTP connection:
+ (define-struct tcp-connection (in out))
- (define (check-expected-result line expected)
- (when expected
- (unless (ormap (lambda (expected)
- (bytes=? expected (subbytes line 0 3)))
- (if (bytes? expected)
- (list expected)
- expected))
- (error 'ftp "exected result code ~a, got ~a" expected line))))
-
- ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any
- ;;
- ;; Checks a standard-format response, checking for the given
- ;; expected 3-digit result code if expected is not #f.
- ;;
- ;; While checking, the function sends reponse lines to
- ;; diagnostic-accum. This function -accum functions can return a
- ;; value that accumulates over multiple calls to the function, and
- ;; accum-start is used as the initial value. Use `void' and
- ;; `(void)' to ignore the response info.
- ;;
- ;; If an unexpected result is found, an exception is raised, and the
- ;; stream is left in an undefined state.
- (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
- (flush-output tcpout)
- (let ([line (read-bytes-line tcpin 'any)])
- (cond
- [(eof-object? line)
- (error 'ftp "unexpected EOF")]
- [(regexp-match re:multi-response-start line)
- (check-expected-result line expected)
- (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
- (let loop ([accum (diagnostic-accum line accum-start)])
- (let ([line (read-bytes-line tcpin 'any)])
- (cond
- [(eof-object? line)
- (error 'ftp "unexpected EOF")]
- [(regexp-match re:done line)
- (diagnostic-accum line accum)]
- [else
- (loop (diagnostic-accum line accum))]))))]
- [(regexp-match re:response-end line)
- (check-expected-result line expected)
- (diagnostic-accum line accum-start)]
- [else
- (error 'ftp "unexpected result: ~e" line)])))
+ (define tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
- (define (get-month month-bytes)
- (cond
- [(equal? #"Jan" month-bytes) 1]
- [(equal? #"Feb" month-bytes) 2]
- [(equal? #"Mar" month-bytes) 3]
- [(equal? #"Apr" month-bytes) 4]
- [(equal? #"May" month-bytes) 5]
- [(equal? #"Jun" month-bytes) 6]
- [(equal? #"Jul" month-bytes) 7]
- [(equal? #"Aug" month-bytes) 8]
- [(equal? #"Sep" month-bytes) 9]
- [(equal? #"Oct" month-bytes) 10]
- [(equal? #"Nov" month-bytes) 11]
- [(equal? #"Dec" month-bytes) 12]))
+ (define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
+ (define re:response-end #rx#"^[0-9][0-9][0-9] ")
- (define (bytes->number bytes)
- (string->number (bytes->string/latin-1 bytes)))
-
- (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
+ (define (check-expected-result line expected)
+ (when expected
+ (unless (ormap (lambda (expected)
+ (bytes=? expected (subbytes line 0 3)))
+ (if (bytes? expected)
+ (list expected)
+ expected))
+ (error 'ftp "exected result code ~a, got ~a" expected line))))
- (define (ftp-make-file-seconds ftp-date-str)
- (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
- (if (not (list-ref date-list 4))
- (find-seconds 0
- 0
- 2
- (bytes->number (list-ref date-list 6))
- (get-month (list-ref date-list 5))
- (bytes->number (list-ref date-list 7)))
- (+ (find-seconds 0
- (bytes->number (list-ref date-list 4))
- (bytes->number (list-ref date-list 3))
- (bytes->number (list-ref date-list 2))
- (get-month (list-ref date-list 1))
- 2002)
- tzoffset))))
-
- (define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
+ ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any
+ ;;
+ ;; Checks a standard-format response, checking for the given
+ ;; expected 3-digit result code if expected is not #f.
+ ;;
+ ;; While checking, the function sends reponse lines to
+ ;; diagnostic-accum. This function -accum functions can return a
+ ;; value that accumulates over multiple calls to the function, and
+ ;; accum-start is used as the initial value. Use `void' and
+ ;; `(void)' to ignore the response info.
+ ;;
+ ;; If an unexpected result is found, an exception is raised, and the
+ ;; stream is left in an undefined state.
+ (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
+ (flush-output tcpout)
+ (let ([line (read-bytes-line tcpin 'any)])
+ (cond
+ [(eof-object? line)
+ (error 'ftp "unexpected EOF")]
+ [(regexp-match re:multi-response-start line)
+ (check-expected-result line expected)
+ (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
+ (let loop ([accum (diagnostic-accum line accum-start)])
+ (let ([line (read-bytes-line tcpin 'any)])
+ (cond [(eof-object? line)
+ (error 'ftp "unexpected EOF")]
+ [(regexp-match re:done line)
+ (diagnostic-accum line accum)]
+ [else
+ (loop (diagnostic-accum line accum))]))))]
+ [(regexp-match re:response-end line)
+ (check-expected-result line expected)
+ (diagnostic-accum line accum-start)]
+ [else
+ (error 'ftp "unexpected result: ~e" line)])))
- (define (establish-data-connection tcp-ports)
- (fprintf (tcp-connection-out tcp-ports) "PASV~n")
- (let ([response (ftp-check-response (tcp-connection-in tcp-ports)
- (tcp-connection-out tcp-ports)
- #"227"
- (lambda (s ignore) s) ;; should be the only response
- (void))])
- (let* ([reg-list (regexp-match re:passive response)]
- [pn1 (and reg-list
- (bytes->number (list-ref reg-list 5)))]
- [pn2 (bytes->number (list-ref reg-list 6))])
- (unless (and reg-list pn1 pn2)
- (error 'ftp "can't understand PASV response: ~e" response))
- (let-values ([(tcp-data tcp-data-out) (tcp-connect (format "~a.~a.~a.~a"
- (list-ref reg-list 1)
- (list-ref reg-list 2)
- (list-ref reg-list 3)
- (list-ref reg-list 4))
- (+ (* 256 pn1) pn2))])
- (fprintf (tcp-connection-out tcp-ports) "TYPE I~n")
- (ftp-check-response (tcp-connection-in tcp-ports)
- (tcp-connection-out tcp-ports)
- #"200" void (void))
- (close-output-port tcp-data-out)
- tcp-data))))
+ (define (get-month month-bytes)
+ (cond [(assoc month-bytes
+ '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
+ (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10)
+ (#"Nov" 11) (#"Dec" 12)))
+ => cadr]
+ [else (error 'get-month "bad month: ~s" month-bytes)]))
- ;; Used where version 0.1a printed responses:
- (define (print-msg s ignore)
- ;; (printf "~a~n" s)
- (void))
+ (define (bytes->number bytes)
+ (string->number (bytes->string/latin-1 bytes)))
- (define (ftp-establish-connection* in out username password)
- (ftp-check-response in out #"220" print-msg (void))
- (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
- (let ([no-password? (ftp-check-response in out (list #"331" #"230")
- (lambda (line 230?)
- (or 230? (regexp-match #rx#"^230" line)))
- #f)])
- (unless no-password?
- (display (bytes-append #"PASS " (string->bytes/locale password) #"\n") out)
- (ftp-check-response in out #"230" void (void))))
- (make-tcp-connection in out))
-
- (define (ftp-establish-connection server-address server-port username password)
- (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
- (ftp-establish-connection* tcpin tcpout username password)))
+ (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
- (define (ftp-close-connection tcp-ports)
- (fprintf (tcp-connection-out tcp-ports) "QUIT~n")
- (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) #"221" void (void))
- (close-input-port (tcp-connection-in tcp-ports))
- (close-output-port (tcp-connection-out tcp-ports)))
+ (define (ftp-make-file-seconds ftp-date-str)
+ (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
+ (if (not (list-ref date-list 4))
+ (find-seconds 0
+ 0
+ 2
+ (bytes->number (list-ref date-list 6))
+ (get-month (list-ref date-list 5))
+ (bytes->number (list-ref date-list 7)))
+ (+ (find-seconds 0
+ (bytes->number (list-ref date-list 4))
+ (bytes->number (list-ref date-list 3))
+ (bytes->number (list-ref date-list 2))
+ (get-month (list-ref date-list 1))
+ 2002)
+ tzoffset))))
- (define (filter-tcp-data tcp-data-port regular-exp)
- (let loop ()
- (let ([theline (read-bytes-line tcp-data-port 'any)])
- (cond
- [(or (eof-object? theline)
- (< (bytes-length theline) 3))
- null]
- [(regexp-match regular-exp theline)
- => (lambda (m)
- (cons (cdr m) (loop)))]
- [else
- ;; ignore unrecognized lines?
- (loop)]))))
+ (define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
- (define (ftp-cd ftp-ports new-dir)
- (display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n")
- (tcp-connection-out ftp-ports))
- (ftp-check-response (tcp-connection-in ftp-ports) (tcp-connection-out ftp-ports)
- #"250" void (void)))
+ (define (establish-data-connection tcp-ports)
+ (fprintf (tcp-connection-out tcp-ports) "PASV\n")
+ (let ([response (ftp-check-response
+ (tcp-connection-in tcp-ports)
+ (tcp-connection-out tcp-ports)
+ #"227"
+ (lambda (s ignore) s) ; should be the only response
+ (void))])
+ (let* ([reg-list (regexp-match re:passive response)]
+ [pn1 (and reg-list
+ (bytes->number (list-ref reg-list 5)))]
+ [pn2 (bytes->number (list-ref reg-list 6))])
+ (unless (and reg-list pn1 pn2)
+ (error 'ftp "can't understand PASV response: ~e" response))
+ (let-values ([(tcp-data tcp-data-out)
+ (tcp-connect (format "~a.~a.~a.~a"
+ (list-ref reg-list 1)
+ (list-ref reg-list 2)
+ (list-ref reg-list 3)
+ (list-ref reg-list 4))
+ (+ (* 256 pn1) pn2))])
+ (fprintf (tcp-connection-out tcp-ports) "TYPE I\n")
+ (ftp-check-response (tcp-connection-in tcp-ports)
+ (tcp-connection-out tcp-ports)
+ #"200" void (void))
+ (close-output-port tcp-data-out)
+ tcp-data))))
- (define re:dir-line #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
+ ;; Used where version 0.1a printed responses:
+ (define (print-msg s ignore)
+ ;; (printf "~a\n" s)
+ (void))
- (define (ftp-directory-list tcp-ports)
- (let ([tcp-data (establish-data-connection tcp-ports)])
- (fprintf (tcp-connection-out tcp-ports) "LIST~n")
- (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
- #"150" void (void))
- (let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
- (close-input-port tcp-data)
- (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
- #"226" print-msg (void))
- (map (lambda (l) (map bytes->string/locale l)) dir-list))))
+ (define (ftp-establish-connection* in out username password)
+ (ftp-check-response in out #"220" print-msg (void))
+ (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
+ (let ([no-password? (ftp-check-response
+ in out (list #"331" #"230")
+ (lambda (line 230?)
+ (or 230? (regexp-match #rx#"^230" line)))
+ #f)])
+ (unless no-password?
+ (display (bytes-append #"PASS " (string->bytes/locale password) #"\n")
+ out)
+ (ftp-check-response in out #"230" void (void))))
+ (make-tcp-connection in out))
- (define (ftp-download-file tcp-ports folder filename)
- ;; Save the file under the name tmp.file,
- ;; rename it once download is complete
- ;; this assures we don't over write any existing file without having a good file down
- (let* ([tmpfile (make-temporary-file (string-append
- (regexp-replace #rx"~"
- (path->string (build-path folder "ftptmp"))
- "~~")
- "~a"))]
- [new-file (open-output-file tmpfile 'replace)]
- [tcpstring (bytes-append #"RETR " (string->bytes/locale filename) #"\n")]
- [tcp-data (establish-data-connection tcp-ports)])
- (display tcpstring (tcp-connection-out tcp-ports))
- (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
- #"150" print-msg (void))
- (copy-port tcp-data new-file)
- (close-output-port new-file)
- (close-input-port tcp-data)
- (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports)
- #"226" print-msg (void))
- (rename-file-or-directory tmpfile (build-path folder filename) #t)))
+ (define (ftp-establish-connection server-address server-port username password)
+ (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
+ (ftp-establish-connection* tcpin tcpout username password)))
- ;; (printf "FTP Client Installed...~n")
- )
+ (define (ftp-close-connection tcp-ports)
+ (fprintf (tcp-connection-out tcp-ports) "QUIT\n")
+ (ftp-check-response (tcp-connection-in tcp-ports)
+ (tcp-connection-out tcp-ports)
+ #"221" void (void))
+ (close-input-port (tcp-connection-in tcp-ports))
+ (close-output-port (tcp-connection-out tcp-ports)))
+
+ (define (filter-tcp-data tcp-data-port regular-exp)
+ (let loop ()
+ (let ([theline (read-bytes-line tcp-data-port 'any)])
+ (cond [(or (eof-object? theline) (< (bytes-length theline) 3))
+ null]
+ [(regexp-match regular-exp theline)
+ => (lambda (m) (cons (cdr m) (loop)))]
+ [else
+ ;; ignore unrecognized lines?
+ (loop)]))))
+
+ (define (ftp-cd ftp-ports new-dir)
+ (display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n")
+ (tcp-connection-out ftp-ports))
+ (ftp-check-response (tcp-connection-in ftp-ports)
+ (tcp-connection-out ftp-ports)
+ #"250" void (void)))
+
+ (define re:dir-line
+ #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
+
+ (define (ftp-directory-list tcp-ports)
+ (let ([tcp-data (establish-data-connection tcp-ports)])
+ (fprintf (tcp-connection-out tcp-ports) "LIST\n")
+ (ftp-check-response (tcp-connection-in tcp-ports)
+ (tcp-connection-out tcp-ports)
+ #"150" void (void))
+ (let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
+ (close-input-port tcp-data)
+ (ftp-check-response (tcp-connection-in tcp-ports)
+ (tcp-connection-out tcp-ports)
+ #"226" print-msg (void))
+ (map (lambda (l) (map bytes->string/locale l)) dir-list))))
+
+ (define (ftp-download-file tcp-ports folder filename)
+ ;; Save the file under the name tmp.file, rename it once download is
+ ;; complete this assures we don't over write any existing file without
+ ;; having a good file down
+ (let* ([tmpfile (make-temporary-file
+ (string-append
+ (regexp-replace
+ #rx"~"
+ (path->string (build-path folder "ftptmp"))
+ "~~")
+ "~a"))]
+ [new-file (open-output-file tmpfile 'replace)]
+ [tcpstring (bytes-append #"RETR "
+ (string->bytes/locale filename)
+ #"\n")]
+ [tcp-data (establish-data-connection tcp-ports)])
+ (display tcpstring (tcp-connection-out tcp-ports))
+ (ftp-check-response (tcp-connection-in tcp-ports)
+ (tcp-connection-out tcp-ports)
+ #"150" print-msg (void))
+ (copy-port tcp-data new-file)
+ (close-output-port new-file)
+ (close-input-port tcp-data)
+ (ftp-check-response (tcp-connection-in tcp-ports)
+ (tcp-connection-out tcp-ports)
+ #"226" print-msg (void))
+ (rename-file-or-directory tmpfile (build-path folder filename) #t)))
+
+ ;; (printf "FTP Client Installed...\n")
+ )
diff --git a/collects/net/head-sig.ss b/collects/net/head-sig.ss
index 631802a..51647f9 100644
--- a/collects/net/head-sig.ss
+++ b/collects/net/head-sig.ss
@@ -11,4 +11,3 @@
data-lines->data
extract-addresses
assemble-address-field)
-
diff --git a/collects/net/head-unit.ss b/collects/net/head-unit.ss
index 93644fd..f0db963 100644
--- a/collects/net/head-unit.ss
+++ b/collects/net/head-unit.ss
@@ -1,400 +1,348 @@
(module head-unit (lib "a-unit.ss")
- (require (lib "date.ss")
- (lib "string.ss")
- "head-sig.ss")
+ (require (lib "date.ss") (lib "string.ss") "head-sig.ss")
(import)
(export head^)
- ;; NB: I've done a copied-code adaptation of a number of these definitions into
- ;; "bytes-compatible" versions. Finishing the rest will require some kind of interface
- ;; decision---that is, when you don't supply a header, should the resulting operation
- ;; be string-centric or bytes-centric? Easiest just to stop here.
- ;; -- JBC 2006-07-31
+ ;; NB: I've done a copied-code adaptation of a number of these definitions
+ ;; into "bytes-compatible" versions. Finishing the rest will require some
+ ;; kind of interface decision---that is, when you don't supply a header,
+ ;; should the resulting operation be string-centric or bytes-centric?
+ ;; Easiest just to stop here.
+ ;; -- JBC 2006-07-31
- (define CRLF (string #\return #\newline))
- (define CRLF/bytes #"\r\n")
-
- (define empty-header CRLF)
- (define empty-header/bytes CRLF/bytes)
+ (define CRLF (string #\return #\newline))
+ (define CRLF/bytes #"\r\n")
- (define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
- (define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
-
- (define re:continue (regexp "^[ \t\v]"))
- (define re:continue/bytes #rx#"^[ \t\v]")
-
-
- (define (validate-header s)
- (if (bytes? s)
- ;; legal char check not needed per rfc 2822, IIUC.
- (let ([len (bytes-length s)])
- (let loop ([offset 0])
- (cond
- [(and (= (+ offset 2) len)
- (bytes=? CRLF/bytes (subbytes s offset len)))
- (void)] ; validated
- [(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
- [(or (regexp-match re:field-start/bytes s offset)
- (regexp-match re:continue/bytes s offset))
- (let ([m (regexp-match-positions #rx#"\r\n" s offset)])
- (if m
- (loop (cdar m))
- (error 'validate-header/bytes "missing ending CRLF")))]
- [else (error 'validate-header/bytes "ill-formed header at ~s"
- (subbytes s offset (string-length s)))])))
- ;; otherwise it should be a string:
- (begin
- (let ([m (regexp-match #rx"[^\000-\377]" s)])
- (when m
- (error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
- (let ([len (string-length s)])
- (let loop ([offset 0])
- (cond
- [(and (= (+ offset 2) len)
- (string=? CRLF (substring s offset len)))
- (void)] ; validated
- [(= offset len) (error 'validate-header "missing ending CRLF")]
- [(or (regexp-match re:field-start s offset)
- (regexp-match re:continue s offset))
- (let ([m (regexp-match-positions #rx"\r\n" s offset)])
- (if m
- (loop (cdar m))
- (error 'validate-header "missing ending CRLF")))]
- [else (error 'validate-header "ill-formed header at ~s"
- (substring s offset (string-length s)))]))))))
-
- (define (make-field-start-regexp field)
- (regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
+ (define empty-header CRLF)
+ (define empty-header/bytes CRLF/bytes)
- (define (make-field-start-regexp/bytes field)
- (byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
+ (define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
+ (define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
-
- (define (extract-field field header)
- (if (bytes? header)
- (let ([m (regexp-match-positions
- (make-field-start-regexp/bytes field)
- header)])
- (and m
- (let ([s (subbytes header
- (cdaddr m)
- (bytes-length header))])
- (let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
- (if m
- (subbytes s 0 (caar m))
- ;; Rest of header is this field, but strip trailing CRLFCRLF:
+ (define re:continue (regexp "^[ \t\v]"))
+ (define re:continue/bytes #rx#"^[ \t\v]")
+
+ (define (validate-header s)
+ (if (bytes? s)
+ ;; legal char check not needed per rfc 2822, IIUC.
+ (let ([len (bytes-length s)])
+ (let loop ([offset 0])
+ (cond
+ [(and (= (+ offset 2) len)
+ (bytes=? CRLF/bytes (subbytes s offset len)))
+ (void)] ; validated
+ [(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
+ [(or (regexp-match re:field-start/bytes s offset)
+ (regexp-match re:continue/bytes s offset))
+ (let ([m (regexp-match-positions #rx#"\r\n" s offset)])
+ (if m
+ (loop (cdar m))
+ (error 'validate-header/bytes "missing ending CRLF")))]
+ [else (error 'validate-header/bytes "ill-formed header at ~s"
+ (subbytes s offset (string-length s)))])))
+ ;; otherwise it should be a string:
+ (begin
+ (let ([m (regexp-match #rx"[^\000-\377]" s)])
+ (when m
+ (error 'validate-header "non-Latin-1 character in string: ~v" (car m))))
+ (let ([len (string-length s)])
+ (let loop ([offset 0])
+ (cond
+ [(and (= (+ offset 2) len)
+ (string=? CRLF (substring s offset len)))
+ (void)] ; validated
+ [(= offset len) (error 'validate-header "missing ending CRLF")]
+ [(or (regexp-match re:field-start s offset)
+ (regexp-match re:continue s offset))
+ (let ([m (regexp-match-positions #rx"\r\n" s offset)])
+ (if m
+ (loop (cdar m))
+ (error 'validate-header "missing ending CRLF")))]
+ [else (error 'validate-header "ill-formed header at ~s"
+ (substring s offset (string-length s)))]))))))
+
+ (define (make-field-start-regexp field)
+ (regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f))))
+
+ (define (make-field-start-regexp/bytes field)
+ (byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)")))
+
+ (define (extract-field field header)
+ (if (bytes? header)
+ (let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
+ header)])
+ (and m
+ (let ([s (subbytes header
+ (cdaddr m)
+ (bytes-length header))])
+ (let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)])
+ (if m
+ (subbytes s 0 (caar m))
+ ;; Rest of header is this field, but strip trailing CRLFCRLF:
+ (regexp-replace #rx#"\r\n\r\n$" s ""))))))
+ ;; otherwise header & field should be strings:
+ (let ([m (regexp-match-positions (make-field-start-regexp field)
+ header)])
+ (and m
+ (let ([s (substring header
+ (cdaddr m)
+ (string-length header))])
+ (let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
+ (if m
+ (substring s 0 (caar m))
+ ;; Rest of header is this field, but strip trailing CRLFCRLF:
+ (regexp-replace #rx"\r\n\r\n$" s ""))))))))
+
+
+ (define (replace-field field data header)
+ (if (bytes? header)
+ (let ([m (regexp-match-positions (make-field-start-regexp/bytes field)
+ header)])
+ (if m
+ (let* ([pre (subbytes header 0 (caaddr m))]
+ [s (subbytes header (cdaddr m))]
+ [m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
+ [rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)])
+ (bytes-append pre (if data (insert-field field data rest) rest)))
+ (if data (insert-field field data header) header)))
+ ;; otherwise header & field & data should be strings:
+ (let ([m (regexp-match-positions (make-field-start-regexp field)
+ header)])
+ (if m
+ (let* ([pre (substring header 0 (caaddr m))]
+ [s (substring header (cdaddr m))]
+ [m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
+ [rest (if m (substring s (+ 2 (caar m))) empty-header)])
+ (string-append pre (if data (insert-field field data rest) rest)))
+ (if data (insert-field field data header) header)))))
+
+ (define (remove-field field header)
+ (replace-field field #f header))
+
+ (define (insert-field field data header)
+ (if (bytes? header)
+ (let ([field (bytes-append field #": "data #"\r\n")])
+ (bytes-append field header))
+ ;; otherwise field, data, & header should be strings:
+ (let ([field (format "~a: ~a\r\n" field data)])
+ (string-append field header))))
+
+ (define (append-headers a b)
+ (if (bytes? a)
+ (let ([alen (bytes-length a)])
+ (if (> alen 1)
+ (bytes-append (subbytes a 0 (- alen 2)) b)
+ (error 'append-headers "first argument is not a header: ~a" a)))
+ ;; otherwise, a & b should be strings:
+ (let ([alen (string-length a)])
+ (if (> alen 1)
+ (string-append (substring a 0 (- alen 2)) b)
+ (error 'append-headers "first argument is not a header: ~a" a)))))
+
+ (define (extract-all-fields header)
+ (if (bytes? header)
+ (let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
+ (let loop ([start 0])
+ (let ([m (regexp-match-positions re header start)])
+ (if m
+ (let ([start (cdaddr m)]
+ [field-name (subbytes header (caaddr (cdr m))
+ (cdaddr (cdr m)))])
+ (let ([m2 (regexp-match-positions
+ #rx#"\r\n[^: \r\n\"]*:"
+ header
+ start)])
+ (if m2
+ (cons (cons field-name
+ (subbytes header start (caar m2)))
+ (loop (caar m2)))
+ ;; Rest of header is this field, but strip trailing CRLFCRLF:
+ (list
+ (cons field-name
(regexp-replace #rx#"\r\n\r\n$"
- s
+ (subbytes header start (bytes-length header))
""))))))
- ;; otherwise header & field should be strings:
- (let ([m (regexp-match-positions
- (make-field-start-regexp field)
- header)])
- (and m
- (let ([s (substring header
- (cdaddr m)
- (string-length header))])
- (let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
- (if m
- (substring s 0 (caar m))
- ;; Rest of header is this field, but strip trailing CRLFCRLF:
+ ;; malformed header:
+ null))))
+ ;; otherwise, header should be a string:
+ (let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
+ (let loop ([start 0])
+ (let ([m (regexp-match-positions re header start)])
+ (if m
+ (let ([start (cdaddr m)]
+ [field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
+ (let ([m2 (regexp-match-positions
+ #rx"\r\n[^: \r\n\"]*:" header start)])
+ (if m2
+ (cons (cons field-name
+ (substring header start (caar m2)))
+ (loop (caar m2)))
+ ;; Rest of header is this field, but strip trailing CRLFCRLF:
+ (list
+ (cons field-name
(regexp-replace #rx"\r\n\r\n$"
- s
- ""))))))))
-
+ (substring header start (string-length header))
+ ""))))))
+ ;; malformed header:
+ null))))))
- (define (replace-field field data header)
- (if (bytes? header)
- (let ([m (regexp-match-positions
- (make-field-start-regexp/bytes field)
- header)])
+ ;; It's slightly less obvious how to generalize the functions that don't
+ ;; accept a header as input; for lack of an obvious solution (and free time),
+ ;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31
+
+ (define (standard-message-header from tos ccs bccs subject)
+ (let ([h (insert-field
+ "Subject" subject
+ (insert-field
+ "Date" (parameterize ([date-display-format 'rfc2822])
+ (date->string (seconds->date (current-seconds)) #t))
+ CRLF))])
+ ;; NOTE: bccs don't go into the header; that's why they're "blind"
+ (let ([h (if (null? ccs)
+ h
+ (insert-field "CC" (assemble-address-field ccs) h))])
+ (let ([h (if (null? tos)
+ h
+ (insert-field "To" (assemble-address-field tos) h))])
+ (insert-field "From" from h)))))
+
+ (define (splice l sep)
+ (if (null? l)
+ ""
+ (format "~a~a"
+ (car l)
+ (apply string-append
+ (map (lambda (n) (format "~a~a" sep n))
+ (cdr l))))))
+
+ (define (data-lines->data datas)
+ (splice datas "\r\n\t"))
+
+ ;; Extracting Addresses ;;
+
+ (define blank "[ \t\n\r\v]")
+ (define nonblank "[^ \t\n\r\v]")
+ (define re:all-blank (regexp (format "^~a*$" blank)))
+ (define re:quoted (regexp "\"[^\"]*\""))
+ (define re:parened (regexp "[(][^)]*[)]"))
+ (define re:comma (regexp ","))
+ (define re:comma-separated (regexp "([^,]*),(.*)"))
+
+ (define (extract-addresses s form)
+ (unless (memq form '(name address full all))
+ (raise-type-error 'extract-addresses
+ "form: 'name, 'address, 'full, or 'all"
+ form))
+ (if (or (not s) (regexp-match re:all-blank s))
+ null
+ (let loop ([prefix ""][s s])
+ ;; Which comes first - a quote or a comma?
+ (let* ([mq1 (regexp-match-positions re:quoted s)]
+ [mq2 (regexp-match-positions re:parened s)]
+ [mq (if (and mq1 mq2)
+ (if (< (caar mq1) (caar mq2))
+ mq1
+ mq2)
+ (or mq1 mq2))]
+ [mc (regexp-match-positions re:comma s)])
+ (if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
+ ;; Quote contains a comma
+ (loop (string-append
+ prefix
+ (substring s 0 (cdar mq)))
+ (substring s (cdar mq) (string-length s)))
+ ;; Normal comma parsing:
+ (let ([m (regexp-match re:comma-separated s)])
(if m
- (let ([pre (subbytes header
- 0
- (caaddr m))]
- [s (subbytes header
- (cdaddr m)
- (bytes-length header))])
- (let* ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]
- [rest (if m
- (subbytes s (+ 2 (caar m))
- (bytes-length s))
- empty-header/bytes)])
- (bytes-append pre
- (if data
- (insert-field field data rest)
- rest))))
- (if data
- (insert-field field data header)
- header)))
- ;; otherwise header & field & data should be strings:
- (let ([m (regexp-match-positions
- (make-field-start-regexp field)
- header)])
- (if m
- (let ([pre (substring header
- 0
- (caaddr m))]
- [s (substring header
- (cdaddr m)
- (string-length header))])
- (let* ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]
- [rest (if m
- (substring s (+ 2 (caar m))
- (string-length s))
- empty-header)])
- (string-append pre
- (if data
- (insert-field field data rest)
- rest))))
- (if data
- (insert-field field data header)
- header)))))
-
- (define (remove-field field header)
- (replace-field field #f header))
-
- (define (insert-field field data header)
- (if (bytes? header)
- (let ([field (bytes-append field #": "data #"\r\n")])
- (bytes-append field header))
- ;; otherwise field, data, & header should be strings:
- (let ([field (format "~a: ~a\r\n"
- field
- data)])
- (string-append field header))))
-
-
- (define (append-headers a b)
- (if (bytes? a)
- (let ([alen (bytes-length a)])
- (if (> alen 1)
- (bytes-append (subbytes a 0 (- alen 2)) b)
- (error 'append-headers "first argument is not a header: ~a" a)))
- ;; otherwise, a & b should be strings:
- (let ([alen (string-length a)])
- (if (> alen 1)
- (string-append (substring a 0 (- alen 2)) b)
- (error 'append-headers "first argument is not a header: ~a" a)))))
-
- (define (extract-all-fields header)
- (if (bytes? header)
- (let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"])
- (let loop ([start 0])
- (let ([m (regexp-match-positions re header start)])
- (if m
- (let ([start (cdaddr m)]
- [field-name (subbytes header (caaddr (cdr m)) (cdaddr (cdr m)))])
- (let ([m2 (regexp-match-positions
- #rx#"\r\n[^: \r\n\"]*:"
- header
- start)])
- (if m2
- (cons (cons field-name
- (subbytes header start (caar m2)))
- (loop (caar m2)))
- ;; Rest of header is this field, but strip trailing CRLFCRLF:
- (list
- (cons field-name
- (regexp-replace #rx#"\r\n\r\n$"
- (subbytes header start (bytes-length header))
- ""))))))
- ;; malformed header:
- null))))
- ;; otherwise, header should be a string:
- (let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
- (let loop ([start 0])
- (let ([m (regexp-match-positions re header start)])
- (if m
- (let ([start (cdaddr m)]
- [field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
- (let ([m2 (regexp-match-positions
- #rx"\r\n[^: \r\n\"]*:"
- header
- start)])
- (if m2
- (cons (cons field-name
- (substring header start (caar m2)))
- (loop (caar m2)))
- ;; Rest of header is this field, but strip trailing CRLFCRLF:
- (list
- (cons field-name
- (regexp-replace #rx"\r\n\r\n$"
- (substring header start (string-length header))
- ""))))))
- ;; malformed header:
- null))))))
-
- ;; It's slightly less obvious how to generalize the functions that don't accept a header
- ;; as input; for lack of an obvious solution (and free time), I'm stopping the string->bytes
- ;; translation here. -- JBC, 2006-07-31
-
- (define (standard-message-header from tos ccs bccs subject)
- (let ([h (insert-field
- "Subject" subject
- (insert-field
- "Date" (parameterize ([date-display-format 'rfc2822])
- (date->string (seconds->date (current-seconds)) #t))
- CRLF))])
- ;; NOTE: bccs don't go into the header; that's why
- ;; they're "blind"
- (let ([h (if (null? ccs)
- h
- (insert-field
- "CC" (assemble-address-field ccs)
- h))])
- (let ([h (if (null? tos)
- h
- (insert-field
- "To" (assemble-address-field tos)
- h))])
- (insert-field
- "From" from
- h)))))
+ (let ([n (extract-one-name (string-append prefix (cadr m)) form)]
+ [rest (extract-addresses (caddr m) form)])
+ (cons n rest))
+ (let ([n (extract-one-name (string-append prefix s) form)])
+ (list n)))))))))
- (define (splice l sep)
- (if (null? l)
- ""
- (format "~a~a"
- (car l)
- (apply
- string-append
- (map
- (lambda (n) (format "~a~a" sep n))
- (cdr l))))))
+ (define (select-result form name addr full)
+ (case form
+ [(name) name]
+ [(address) addr]
+ [(full) full]
+ [(all) (list name addr full)]))
- (define (data-lines->data datas)
- (splice datas "\r\n\t"))
+ (define (one-result form s)
+ (select-result form s s s))
- ;; Extracting Addresses ;;
+ (define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
+ (define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
+ (define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
+ (define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
+ (define re:double-less (regexp "<.*<"))
+ (define re:double-greater (regexp ">.*>"))
+ (define re:bad-chars (regexp "[,\"()<>]"))
+ (define re:tail-blanks (regexp (format "~a+$" blank)))
+ (define re:head-blanks (regexp (format "^~a+" blank)))
- (define blank "[ \t\n\r\v]")
- (define nonblank "[^ \t\n\r\v]")
- (define re:all-blank (regexp (format "^~a*$" blank)))
- (define re:quoted (regexp "\"[^\"]*\""))
- (define re:parened (regexp "[(][^)]*[)]"))
- (define re:comma (regexp ","))
- (define re:comma-separated (regexp "([^,]*),(.*)"))
+ (define (extract-one-name orig form)
+ (let loop ([s orig][form form])
+ (cond
+ ;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
+ [(regexp-match re:parened-name s)
+ => (lambda (m)
+ (let ([name (caddr m)]
+ [all (loop (cadr m) 'all)])
+ (select-result
+ form
+ (if (string=? (car all) (cadr all)) name (car all))
+ (cadr all)
+ (format "~a (~a)" (caddr all) name))))]
+ [(regexp-match re:quoted-name s)
+ => (lambda (m)
+ (let ([name (cadr m)]
+ [addr (extract-angle-addr (caddr m) s)])
+ (select-result form name addr
+ (format "~a <~a>" name addr))))]
+ [(regexp-match re:simple-name s)
+ => (lambda (m)
+ (let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
+ [addr (extract-angle-addr (caddr m) s)])
+ (select-result form name addr
+ (format "~a <~a>" name addr))))]
+ [(or (regexp-match "<" s) (regexp-match ">" s))
+ (one-result form (extract-angle-addr s orig))]
+ [else (one-result form (extract-simple-addr s orig))])))
- (define (extract-addresses s form)
- (unless (memq form '(name address full all))
- (raise-type-error 'extract-addresses
- "form: 'name, 'address, 'full, or 'all"
- form))
- (if (or (not s) (regexp-match re:all-blank s))
- null
- (let loop ([prefix ""][s s])
- ;; Which comes first - a quote or a comma?
- (let* ([mq1 (regexp-match-positions re:quoted s)]
- [mq2 (regexp-match-positions re:parened s)]
- [mq (if (and mq1 mq2)
- (if (< (caar mq1) (caar mq2))
- mq1
- mq2)
- (or mq1 mq2))]
- [mc (regexp-match-positions re:comma s)])
- (if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
- ;; Quote contains a comma
- (loop (string-append
- prefix
- (substring s 0 (cdar mq)))
- (substring s (cdar mq) (string-length s)))
- ;; Normal comma parsing:
- (let ([m (regexp-match re:comma-separated s)])
- (if m
- (let ([n (extract-one-name (string-append prefix (cadr m)) form)]
- [rest (extract-addresses (caddr m) form)])
- (cons n rest))
- (let ([n (extract-one-name (string-append prefix s) form)])
- (list n)))))))))
-
- (define (select-result form name addr full)
- (case form
- [(name) name]
- [(address) addr]
- [(full) full]
- [(all) (list name addr full)]))
+ (define (extract-angle-addr s orig)
+ (if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
+ (error 'extract-address "too many angle brackets: ~a" s)
+ (let ([m (regexp-match re:normal-name s)])
+ (if m
+ (extract-simple-addr (cadr m) orig)
+ (error 'extract-address "cannot parse address: ~a" orig)))))
- (define (one-result form s)
- (select-result form s s s))
+ (define (extract-simple-addr s orig)
+ (cond [(regexp-match re:bad-chars s)
+ (error 'extract-address "cannot parse address: ~a" orig)]
+ [else
+ ;; final whitespace strip
+ (regexp-replace re:tail-blanks
+ (regexp-replace re:head-blanks s "")
+ "")]))
- (define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
- (define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
- (define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
- (define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
- (define re:double-less (regexp "<.*<"))
- (define re:double-greater (regexp ">.*>"))
- (define re:bad-chars (regexp "[,\"()<>]"))
- (define re:tail-blanks (regexp (format "~a+$" blank)))
- (define re:head-blanks (regexp (format "^~a+" blank)))
-
- (define (extract-one-name orig form)
- (let loop ([s orig][form form])
- (cond
- ;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
- [(regexp-match re:parened-name s)
- => (lambda (m)
- (let ([name (caddr m)]
- [all (loop (cadr m) 'all)])
- (select-result form
- (if (string=? (car all) (cadr all))
- name
- (car all))
- (cadr all)
- (format "~a (~a)" (caddr all) name))))]
- [(regexp-match re:quoted-name s)
- => (lambda (m)
- (let ([name (cadr m)]
- [addr (extract-angle-addr (caddr m) s)])
- (select-result form name addr
- (format "~a <~a>" name addr))))]
- [(regexp-match re:simple-name s)
- => (lambda (m)
- (let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
- [addr (extract-angle-addr (caddr m) s)])
- (select-result form name addr
- (format "~a <~a>" name addr))))]
- [(or (regexp-match "<" s) (regexp-match ">" s))
- (one-result form (extract-angle-addr s orig))]
- [else
- (one-result form (extract-simple-addr s orig))])))
-
- (define (extract-angle-addr s orig)
- (if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
- (error 'extract-address "too many angle brackets: ~a" s)
- (let ([m (regexp-match re:normal-name s)])
- (if m
- (extract-simple-addr (cadr m) orig)
- (error 'extract-address "cannot parse address: ~a" orig)))))
-
- (define (extract-simple-addr s orig)
- (cond
- [(regexp-match re:bad-chars s)
- (error 'extract-address "cannot parse address: ~a" orig)]
- [else
- ;; final whitespace strip
- (regexp-replace
- re:tail-blanks
- (regexp-replace re:head-blanks s "")
- "")]))
-
- (define (assemble-address-field addresses)
- (if (null? addresses)
- ""
- (let loop ([addresses (cdr addresses)]
- [s (car addresses)]
- [len (string-length (car addresses))])
- (if (null? addresses)
- s
- (let* ([addr (car addresses)]
- [alen (string-length addr)])
- (if (<= 72 (+ len alen))
- (loop (cdr addresses)
- (format "~a,~a~a~a~a"
- s #\return #\linefeed
- #\tab addr)
- alen)
- (loop (cdr addresses)
- (format "~a, ~a" s addr)
- (+ len alen 2)))))))))
+ (define (assemble-address-field addresses)
+ (if (null? addresses)
+ ""
+ (let loop ([addresses (cdr addresses)]
+ [s (car addresses)]
+ [len (string-length (car addresses))])
+ (if (null? addresses)
+ s
+ (let* ([addr (car addresses)]
+ [alen (string-length addr)])
+ (if (<= 72 (+ len alen))
+ (loop (cdr addresses)
+ (format "~a,~a~a~a~a"
+ s #\return #\linefeed
+ #\tab addr)
+ alen)
+ (loop (cdr addresses)
+ (format "~a, ~a" s addr)
+ (+ len alen 2)))))))))
diff --git a/collects/net/imap-sig.ss b/collects/net/imap-sig.ss
index df074c0..a9555de 100644
--- a/collects/net/imap-sig.ss
+++ b/collects/net/imap-sig.ss
@@ -1,7 +1,7 @@
(module imap-sig (lib "a-signature.ss")
imap-port-number
imap-connection?
-
+
imap-connect imap-connect*
imap-disconnect
imap-force-disconnect
@@ -10,7 +10,7 @@
imap-noop
imap-status
imap-poll
-
+
imap-new?
imap-messages
imap-recent
@@ -18,21 +18,20 @@
imap-uidvalidity
imap-unseen
imap-reset-new!
-
+
imap-get-expunges
imap-pending-expunges?
imap-get-updates
imap-pending-updates?
-
+
imap-get-messages
imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag
imap-expunge
-
+
imap-mailbox-exists?
imap-create-mailbox
-
+
imap-list-child-mailboxes
imap-mailbox-flags
imap-get-hierarchy-delimiter)
-
diff --git a/collects/net/imap-unit.ss b/collects/net/imap-unit.ss
index c30b76c..e23486e 100644
--- a/collects/net/imap-unit.ss
+++ b/collects/net/imap-unit.ss
@@ -1,571 +1,538 @@
(module imap-unit (lib "a-unit.ss")
- (require (lib "list.ss")
- "imap-sig.ss"
- "private/rbtree.ss")
-
+ (require (lib "list.ss") "imap-sig.ss" "private/rbtree.ss")
+
(import)
(export imap^)
- (define debug-via-stdio? #f)
+ (define debug-via-stdio? #f)
- (define eol (if debug-via-stdio?
- 'linefeed
- 'return-linefeed))
+ (define eol (if debug-via-stdio? 'linefeed 'return-linefeed))
- (define (tag-eq? a b)
- (or (eq? a b)
- (and (symbol? a)
- (symbol? b)
- (string-ci=? (symbol->string a)
- (symbol->string b)))))
+ (define (tag-eq? a b)
+ (or (eq? a b)
+ (and (symbol? a)
+ (symbol? b)
+ (string-ci=? (symbol->string a) (symbol->string b)))))
- (define field-names
- (list
- (list 'uid (string->symbol "UID"))
- (list 'header (string->symbol "RFC822.HEADER"))
- (list 'body (string->symbol "RFC822.TEXT"))
- (list 'size (string->symbol "RFC822.SIZE"))
- (list 'flags (string->symbol "FLAGS"))))
+ (define field-names
+ (list (list 'uid (string->symbol "UID"))
+ (list 'header (string->symbol "RFC822.HEADER"))
+ (list 'body (string->symbol "RFC822.TEXT"))
+ (list 'size (string->symbol "RFC822.SIZE"))
+ (list 'flags (string->symbol "FLAGS"))))
- (define flag-names
- (list
- (list 'seen (string->symbol "\\Seen"))
- (list 'answered (string->symbol "\\Answered"))
- (list 'flagged (string->symbol "\\Flagged"))
- (list 'deleted (string->symbol "\\Deleted"))
- (list 'draft (string->symbol "\\Draft"))
- (list 'recent (string->symbol "\\Recent"))
+ (define flag-names
+ (list (list 'seen (string->symbol "\\Seen"))
+ (list 'answered (string->symbol "\\Answered"))
+ (list 'flagged (string->symbol "\\Flagged"))
+ (list 'deleted (string->symbol "\\Deleted"))
+ (list 'draft (string->symbol "\\Draft"))
+ (list 'recent (string->symbol "\\Recent"))
- (list 'noinferiors (string->symbol "\\Noinferiors"))
- (list 'noselect (string->symbol "\\Noselect"))
- (list 'marked (string->symbol "\\Marked"))
- (list 'unmarked (string->symbol "\\Unmarked"))
+ (list 'noinferiors (string->symbol "\\Noinferiors"))
+ (list 'noselect (string->symbol "\\Noselect"))
+ (list 'marked (string->symbol "\\Marked"))
+ (list 'unmarked (string->symbol "\\Unmarked"))
- (list 'hasnochildren (string->symbol "\\HasNoChildren"))
- (list 'haschildren (string->symbol "\\HasChildren"))))
+ (list 'hasnochildren (string->symbol "\\HasNoChildren"))
+ (list 'haschildren (string->symbol "\\HasChildren"))))
- (define (imap-flag->symbol f)
- (or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a)))
- flag-names)
- f))
+ (define (imap-flag->symbol f)
+ (or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a))) flag-names)
+ f))
- (define (symbol->imap-flag s)
- (let ([a (assoc s flag-names)])
- (if a
- (cadr a)
- s)))
+ (define (symbol->imap-flag s)
+ (cond [(assoc s flag-names) => cadr] [else s]))
- (define (log-warning . args)
- ;; (apply printf args)
- (void))
- (define log log-warning)
+ (define (log-warning . args)
+ ;; (apply printf args)
+ (void))
+ (define log log-warning)
- (define make-msg-id
- (let ([id 0])
- (lambda ()
- (begin0
- (string->bytes/latin-1 (format "a~a " id))
- (set! id (add1 id))))))
+ (define make-msg-id
+ (let ([id 0])
+ (lambda ()
+ (begin0 (string->bytes/latin-1 (format "a~a " id))
+ (set! id (add1 id))))))
- (define (starts-with? l n)
- (and (>= (bytes-length l) (bytes-length n))
- (bytes=? n (subbytes l 0 (bytes-length n)))))
+ (define (starts-with? l n)
+ (and (>= (bytes-length l) (bytes-length n))
+ (bytes=? n (subbytes l 0 (bytes-length n)))))
- (define (skip s n)
- (subbytes s
- (if (number? n) n (bytes-length n))
- (bytes-length s)))
-
- (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 (skip s n)
+ (subbytes s (if (number? n) n (bytes-length n))))
- (define (imap-read s r)
- (let loop ([s s]
- [r r]
- [accum null]
- [eol-k (lambda (accum) (reverse! accum))]
- [eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))])
- (cond
- [(bytes=? #"" s)
- (eol-k accum)]
- [(char-whitespace? (integer->char (bytes-ref s 0)))
- (loop (skip s 1) r accum eol-k eop-k)]
- [else
- (case (integer->char (bytes-ref s 0))
- [(#\")
- (let ([m (regexp-match #rx#"\"([^\"]*)\"(.*)" s)])
- (if m
- (loop (caddr m) r (cons (cadr m) accum) eol-k eop-k)
- (error 'imap-read "didn't find end of quoted string in: ~a" s)))]
- [(#\))
- (eop-k (skip s 1) accum)]
- [(#\() (letrec ([next-line
- (lambda (accum)
- (loop (read-bytes-line r eol) r
- accum
- next-line
- finish-parens))]
- [finish-parens
- (lambda (s laccum)
- (loop s r
- (cons (reverse! laccum) accum)
- eol-k eop-k))])
- (loop (skip s 1) r null next-line finish-parens))]
- [(#\{) (let ([m (regexp-match #rx#"{([0-9]+)}(.*)" s)])
- (cond
- [(not m) (error 'imap-read "couldn't read {} number: ~a" s)]
- [(not (bytes=? (caddr m) #"")) (error 'imap-read "{} not at end-of-line: ~a" s)]
- [else
- (loop #"" r
- (cons (read-bytes (string->number
- (bytes->string/latin-1 (cadr m)))
- r)
- accum)
- eol-k eop-k)]))]
- [else (let ([m (regexp-match #rx#"([^ (){}]+)(.*)" s)])
- (if m
- (loop (caddr m) r
- (cons (let ([v (cadr m)])
- (if (regexp-match #rx#"^[0-9]*$" v)
- (string->number (bytes->string/latin-1 v))
- (string->symbol (bytes->string/latin-1 v))))
- accum)
- eol-k eop-k)
- (error 'imap-read "failure reading atom: ~a" s)))])])))
+ (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 (get-response r id info-handler continuation-handler)
- (let loop ()
- (let ([l (read-bytes-line r eol)])
- (log "raw-reply: ~s~n" l)
- (cond
- [(eof-object? l)
- (error 'imap-send "unexpected end-of-file from server")]
- [(and id (starts-with? l id))
- (let ([reply (imap-read (skip l id) r)])
- (log "response: ~a~n" reply)
- reply)]
- [(starts-with? l #"* ")
- (let ([info (imap-read (skip l 2) r)])
- (log "info: ~s~n" info)
- (info-handler info))
- (when id
- (loop))]
- [(starts-with? l #"+ ")
- (if (null? continuation-handler)
- (error 'imap-send "unexpected continuation request: ~a" l)
- ((car continuation-handler) loop (imap-read (skip l 2) r)))]
- [else
- (log-warning "warning: unexpected response for ~a: ~a~n" id l)
- (when id
- (loop))]))))
+ (define (imap-read s r)
+ (let loop ([s s]
+ [r r]
+ [accum null]
+ [eol-k (lambda (accum) (reverse! accum))]
+ [eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))])
+ (cond
+ [(bytes=? #"" s)
+ (eol-k accum)]
+ [(char-whitespace? (integer->char (bytes-ref s 0)))
+ (loop (skip s 1) r accum eol-k eop-k)]
+ [else
+ (case (integer->char (bytes-ref s 0))
+ [(#\")
+ (let ([m (regexp-match #rx#"\"([^\"]*)\"(.*)" s)])
+ (if m
+ (loop (caddr m) r (cons (cadr m) accum) eol-k eop-k)
+ (error 'imap-read "didn't find end of quoted string in: ~a" s)))]
+ [(#\))
+ (eop-k (skip s 1) accum)]
+ [(#\() (letrec ([next-line
+ (lambda (accum)
+ (loop (read-bytes-line r eol) r
+ accum
+ next-line
+ finish-parens))]
+ [finish-parens
+ (lambda (s laccum)
+ (loop s r
+ (cons (reverse! laccum) accum)
+ eol-k eop-k))])
+ (loop (skip s 1) r null next-line finish-parens))]
+ [(#\{) (let ([m (regexp-match #rx#"{([0-9]+)}(.*)" s)])
+ (cond
+ [(not m) (error 'imap-read "couldn't read {} number: ~a" s)]
+ [(not (bytes=? (caddr m) #"")) (error 'imap-read "{} not at end-of-line: ~a" s)]
+ [else
+ (loop #"" r
+ (cons (read-bytes (string->number
+ (bytes->string/latin-1 (cadr m)))
+ r)
+ accum)
+ eol-k eop-k)]))]
+ [else (let ([m (regexp-match #rx#"([^ (){}]+)(.*)" s)])
+ (if m
+ (loop (caddr m) r
+ (cons (let ([v (cadr m)])
+ (if (regexp-match #rx#"^[0-9]*$" v)
+ (string->number (bytes->string/latin-1 v))
+ (string->symbol (bytes->string/latin-1 v))))
+ accum)
+ eol-k eop-k)
+ (error 'imap-read "failure reading atom: ~a" s)))])])))
- ;; A cmd is
- ;; * (box v) - send v literally via ~a
- ;; * string or bytes - protect as necessary
- ;; * (cons cmd null) - same as cmd
- ;; * (cons cmd cmd) - send cmd, space, cmd
+ (define (get-response r id info-handler continuation-handler)
+ (let loop ()
+ (let ([l (read-bytes-line r eol)])
+ (log "raw-reply: ~s\n" l)
+ (cond [(eof-object? l)
+ (error 'imap-send "unexpected end-of-file from server")]
+ [(and id (starts-with? l id))
+ (let ([reply (imap-read (skip l id) r)])
+ (log "response: ~a\n" reply)
+ reply)]
+ [(starts-with? l #"* ")
+ (let ([info (imap-read (skip l 2) r)])
+ (log "info: ~s\n" info)
+ (info-handler info))
+ (when id
+ (loop))]
+ [(starts-with? l #"+ ")
+ (if (null? continuation-handler)
+ (error 'imap-send "unexpected continuation request: ~a" l)
+ ((car continuation-handler) loop (imap-read (skip l 2) r)))]
+ [else
+ (log-warning "warning: unexpected response for ~a: ~a\n" id l)
+ (when id (loop))]))))
- (define (imap-send imap cmd info-handler . continuation-handler)
- (let ([r (imap-r imap)]
- [w (imap-w imap)]
- [id (make-msg-id)])
- (log "sending ~a~a~n" id cmd)
- (fprintf w "~a" id)
- (let loop ([cmd cmd])
- (cond
- [(box? cmd) (fprintf w "~a" (unbox cmd))]
- [(string? cmd) (loop (string->bytes/utf-8 cmd))]
- [(bytes? cmd) (if (or (regexp-match #rx#"[ *\"\r\n]" cmd)
- (equal? cmd #""))
- (if (regexp-match #rx#"[\"\r\n]" cmd)
- (begin
- ;; Have to send size, then continue if the
- ;; server consents
- (fprintf w "{~a}\r\n" (bytes-length cmd))
- (flush-output w)
- (get-response r #f void (list (lambda (gloop data) (void))))
- ;; Continue by writing the data
- (write-bytes cmd w))
- (fprintf w "\"~a\"" cmd))
- (fprintf w "~a" cmd))]
- [(and (pair? cmd) (null? (cdr cmd))) (loop (car cmd))]
- [(pair? cmd) (begin (loop (car cmd))
- (fprintf w " ")
- (loop (cdr cmd)))]))
- (fprintf w "\r\n")
- (flush-output w)
- (get-response r id (wrap-info-handler imap info-handler) continuation-handler)))
+ ;; A cmd is
+ ;; * (box v) - send v literally via ~a
+ ;; * string or bytes - protect as necessary
+ ;; * (cons cmd null) - same as cmd
+ ;; * (cons cmd cmd) - send cmd, space, cmd
- (define (check-ok reply)
- (unless (and (pair? reply)
- (tag-eq? (car reply) 'OK))
- (error 'check-ok "server error: ~s" reply)))
+ (define (imap-send imap cmd info-handler . continuation-handler)
+ (let ([r (imap-r imap)]
+ [w (imap-w imap)]
+ [id (make-msg-id)])
+ (log "sending ~a~a\n" id cmd)
+ (fprintf w "~a" id)
+ (let loop ([cmd cmd])
+ (cond
+ [(box? cmd) (fprintf w "~a" (unbox cmd))]
+ [(string? cmd) (loop (string->bytes/utf-8 cmd))]
+ [(bytes? cmd)
+ (if (or (regexp-match #rx#"[ *\"\r\n]" cmd)
+ (equal? cmd #""))
+ (if (regexp-match #rx#"[\"\r\n]" cmd)
+ (begin
+ ;; Have to send size, then continue if the
+ ;; server consents
+ (fprintf w "{~a}\r\n" (bytes-length cmd))
+ (flush-output w)
+ (get-response r #f void (list (lambda (gloop data) (void))))
+ ;; Continue by writing the data
+ (write-bytes cmd w))
+ (fprintf w "\"~a\"" cmd))
+ (fprintf w "~a" cmd))]
+ [(and (pair? cmd) (null? (cdr cmd))) (loop (car cmd))]
+ [(pair? cmd) (begin (loop (car cmd))
+ (fprintf w " ")
+ (loop (cdr cmd)))]))
+ (fprintf w "\r\n")
+ (flush-output w)
+ (get-response r id (wrap-info-handler imap info-handler)
+ continuation-handler)))
- (define (ok-tag-eq? i t)
- (and (tag-eq? (car i) 'OK)
- ((length i) . >= . 3)
- (tag-eq? (cadr i) (string->symbol (format "[~a" t)))))
+ (define (check-ok reply)
+ (unless (and (pair? reply) (tag-eq? (car reply) 'OK))
+ (error 'check-ok "server error: ~s" reply)))
- (define (ok-tag-val i)
- (let ([v (caddr i)])
- (and (symbol? v)
- (let ([v (symbol->string v)])
- (regexp-match #rx"[]]$" v)
- (string->number (substring v 0 (sub1 (string-length v))))))))
-
- (define (wrap-info-handler imap info-handler)
- (lambda (i)
- (when (and (list? i) ((length i) . >= . 2))
- (cond
- [(tag-eq? (cadr i) 'EXISTS)
- (when (> (car i) (or (imap-exists imap) 0))
- (set-imap-new?! imap #t))
- (set-imap-exists! imap (car i))]
- [(tag-eq? (cadr i) 'RECENT)
- (set-imap-recent! imap (car i))]
- [(tag-eq? (cadr i) 'EXPUNGE)
- (let ([n (car i)])
- (log "Recording expunge: ~s~n" n)
- ;; add it to the tree of expunges
- (expunge-insert! (imap-expunges imap) n)
- ;; decrement exists count:
- (set-imap-exists! imap (sub1 (imap-exists imap)))
- ;; adjust ids for any remembered fetches:
- (fetch-shift! (imap-fetches imap) n))]
- [(tag-eq? (cadr i) 'FETCH)
- (fetch-insert! (imap-fetches imap)
- ;; Convert result to assoc list:
- (cons (car i)
- (let ([new
- (let loop ([l (caddr i)])
- (if (null? l)
- null
- (cons (cons (car l) (cadr l))
- (loop (cddr l)))))])
- ;; Keep anything not overridden:
- (let ([old (cdr (or (fetch-find (imap-fetches imap) (car i))
- '(0)))])
- (let loop ([old old][new new])
- (cond
- [(null? old) new]
- [(assq (caar old) new)
- (loop (cdr old) new)]
- [else (loop (cdr old) (cons (car old) new))]))))))]
- [(ok-tag-eq? i 'UIDNEXT)
- (set-imap-uidnext! imap (ok-tag-val i))]
- [(ok-tag-eq? i 'UIDVALIDITY)
- (set-imap-uidvalidity! imap (ok-tag-val i))]
- [(ok-tag-eq? i 'UNSEEN)
- (set-imap-uidvalidity! imap (ok-tag-val i))]))
- (info-handler i)))
-
- (define-struct imap (r w
- exists recent unseen uidnext uidvalidity
- expunges fetches new?))
- (define (imap-connection? v) (imap? v))
-
- (define imap-port-number (make-parameter 143
- (lambda (v)
- (unless (and (number? v)
- (exact? v)
- (integer? v)
- (<= 1 v 65535))
- (raise-type-error 'imap-port-number
- "exact integer in [1,65535]"
- v))
- v)))
+ (define (ok-tag-eq? i t)
+ (and (tag-eq? (car i) 'OK)
+ ((length i) . >= . 3)
+ (tag-eq? (cadr i) (string->symbol (format "[~a" t)))))
- (define (imap-connect* r w username password inbox)
- (with-handlers ([void
- (lambda (x)
- (close-input-port r)
- (close-output-port w)
- (raise x))])
-
- (let ([imap (make-imap r w
- #f #f #f #f #f
- (new-tree) (new-tree) #f)])
- (check-ok (imap-send imap "NOOP" void))
- (let ([reply (imap-send imap (list "LOGIN" username password) void)])
- (if (and (pair? reply) (tag-eq? 'NO (car reply)))
- (error 'imap-connect "username or password rejected by server: ~s" reply)
- (check-ok reply)))
- (let-values ([(init-count init-recent) (imap-reselect imap inbox)])
- (values imap
- init-count
- init-recent)))))
+ (define (ok-tag-val i)
+ (let ([v (caddr i)])
+ (and (symbol? v)
+ (let ([v (symbol->string v)])
+ (regexp-match #rx"[]]$" v)
+ (string->number (substring v 0 (sub1 (string-length v))))))))
- (define (imap-connect server username password inbox)
- ;; => imap count-k recent-k
- (let-values ([(r w) (if debug-via-stdio?
- (begin
- (printf "stdin == ~a~n" server)
- (values (current-input-port) (current-output-port)))
- (tcp-connect server (imap-port-number)))])
- (imap-connect* r w username password inbox)))
-
- (define (imap-reselect imap inbox)
- (imap-selectish-command imap (list "SELECT" inbox) #t))
+ (define (wrap-info-handler imap info-handler)
+ (lambda (i)
+ (when (and (list? i) ((length i) . >= . 2))
+ (cond
+ [(tag-eq? (cadr i) 'EXISTS)
+ (when (> (car i) (or (imap-exists imap) 0))
+ (set-imap-new?! imap #t))
+ (set-imap-exists! imap (car i))]
+ [(tag-eq? (cadr i) 'RECENT)
+ (set-imap-recent! imap (car i))]
+ [(tag-eq? (cadr i) 'EXPUNGE)
+ (let ([n (car i)])
+ (log "Recording expunge: ~s\n" n)
+ ;; add it to the tree of expunges
+ (expunge-insert! (imap-expunges imap) n)
+ ;; decrement exists count:
+ (set-imap-exists! imap (sub1 (imap-exists imap)))
+ ;; adjust ids for any remembered fetches:
+ (fetch-shift! (imap-fetches imap) n))]
+ [(tag-eq? (cadr i) 'FETCH)
+ (fetch-insert!
+ (imap-fetches imap)
+ ;; Convert result to assoc list:
+ (cons (car i)
+ (let ([new
+ (let loop ([l (caddr i)])
+ (if (null? l)
+ null
+ (cons (cons (car l) (cadr l))
+ (loop (cddr l)))))])
+ ;; Keep anything not overridden:
+ (let ([old (cdr (or (fetch-find (imap-fetches imap) (car i))
+ '(0)))])
+ (let loop ([old old][new new])
+ (cond
+ [(null? old) new]
+ [(assq (caar old) new)
+ (loop (cdr old) new)]
+ [else (loop (cdr old) (cons (car old) new))]))))))]
+ [(ok-tag-eq? i 'UIDNEXT)
+ (set-imap-uidnext! imap (ok-tag-val i))]
+ [(ok-tag-eq? i 'UIDVALIDITY)
+ (set-imap-uidvalidity! imap (ok-tag-val i))]
+ [(ok-tag-eq? i 'UNSEEN)
+ (set-imap-uidvalidity! imap (ok-tag-val i))]))
+ (info-handler i)))
- (define (imap-examine imap inbox)
- (imap-selectish-command imap (list "EXAMINE" inbox) #t))
+ (define-struct imap (r w exists recent unseen uidnext uidvalidity
+ expunges fetches new?))
+ (define (imap-connection? v) (imap? v))
- ;; Used to return (values #f #f) if no change since last check?
- (define (imap-noop imap)
- (imap-selectish-command imap "NOOP" #f))
+ (define imap-port-number
+ (make-parameter 143
+ (lambda (v)
+ (unless (and (number? v)
+ (exact? v)
+ (integer? v)
+ (<= 1 v 65535))
+ (raise-type-error 'imap-port-number
+ "exact integer in [1,65535]"
+ v))
+ v)))
- (define (imap-selectish-command imap cmd reset?)
- (let ([init-count #f]
- [init-recent #f])
- (check-ok (imap-send imap cmd void))
- (when reset?
- (set-imap-expunges! imap (new-tree))
- (set-imap-fetches! imap (new-tree))
- (set-imap-new?! imap #f))
- (values (imap-exists imap) (imap-recent imap))))
+ (define (imap-connect* r w username password inbox)
+ (with-handlers ([void
+ (lambda (x)
+ (close-input-port r)
+ (close-output-port w)
+ (raise x))])
- (define (imap-status imap inbox flags)
- (unless (and (list? flags)
- (andmap (lambda (s)
- (memq s '(messages recent uidnext uidvalidity unseen)))
- flags))
- (raise-type-error 'imap-status "list of status flag symbols" flags))
- (let ([results null])
- (check-ok (imap-send imap (list "STATUS" inbox
- (box (format "~a" flags)))
- (lambda (i)
- (when (and (list? i) (= 3 (length i))
- (tag-eq? (car i) 'STATUS))
- (set! results (caddr i))))))
- (map
- (lambda (f)
- (let loop ([l results])
- (cond
- [(or (null? l) (null? (cdr l))) #f]
- [(tag-eq? f (car l)) (cadr l)]
- [else (loop (cdr l))])))
- flags)))
+ (let ([imap (make-imap r w #f #f #f #f #f
+ (new-tree) (new-tree) #f)])
+ (check-ok (imap-send imap "NOOP" void))
+ (let ([reply (imap-send imap (list "LOGIN" username password) void)])
+ (if (and (pair? reply) (tag-eq? 'NO (car reply)))
+ (error 'imap-connect
+ "username or password rejected by server: ~s" reply)
+ (check-ok reply)))
+ (let-values ([(init-count init-recent) (imap-reselect imap inbox)])
+ (values imap init-count init-recent)))))
- (define (imap-poll imap)
- ;; Check for async messages from the server
- (when (char-ready? (imap-r imap))
- ;; It has better start with "*"...
- (when (= (peek-byte (imap-r imap))
- (char->integer #\*))
- ;; May set fields in `imap':
- (get-response (imap-r imap) #f (wrap-info-handler imap void) null)
- (void))))
+ (define (imap-connect server username password inbox)
+ ;; => imap count-k recent-k
+ (let-values ([(r w)
+ (if debug-via-stdio?
+ (begin
+ (printf "stdin == ~a\n" server)
+ (values (current-input-port) (current-output-port)))
+ (tcp-connect server (imap-port-number)))])
+ (imap-connect* r w username password inbox)))
- (define (imap-get-updates imap)
- (no-expunges 'imap-updates imap)
- (let ([l (fetch-tree->list (imap-fetches imap))])
- (set-imap-fetches! imap (new-tree))
- l))
+ (define (imap-reselect imap inbox)
+ (imap-selectish-command imap (list "SELECT" inbox) #t))
- (define (imap-pending-updates? imap)
- (not (tree-empty? (imap-fetches imap))))
+ (define (imap-examine imap inbox)
+ (imap-selectish-command imap (list "EXAMINE" inbox) #t))
- (define (imap-get-expunges imap)
- (let ([l (expunge-tree->list (imap-expunges imap))])
- (set-imap-expunges! imap (new-tree))
- l))
+ ;; Used to return (values #f #f) if no change since last check?
+ (define (imap-noop imap)
+ (imap-selectish-command imap "NOOP" #f))
- (define (imap-pending-expunges? imap)
- (not (tree-empty? (imap-expunges imap))))
+ (define (imap-selectish-command imap cmd reset?)
+ (let ([init-count #f]
+ [init-recent #f])
+ (check-ok (imap-send imap cmd void))
+ (when reset?
+ (set-imap-expunges! imap (new-tree))
+ (set-imap-fetches! imap (new-tree))
+ (set-imap-new?! imap #f))
+ (values (imap-exists imap) (imap-recent imap))))
- (define (imap-reset-new! imap)
- (set-imap-new?! imap #f))
+ (define (imap-status imap inbox flags)
+ (unless (and (list? flags)
+ (andmap (lambda (s)
+ (memq s '(messages recent uidnext uidvalidity unseen)))
+ flags))
+ (raise-type-error 'imap-status "list of status flag symbols" flags))
+ (let ([results null])
+ (check-ok (imap-send imap (list "STATUS" inbox (box (format "~a" flags)))
+ (lambda (i)
+ (when (and (list? i) (= 3 (length i))
+ (tag-eq? (car i) 'STATUS))
+ (set! results (caddr i))))))
+ (map (lambda (f)
+ (let loop ([l results])
+ (cond
+ [(or (null? l) (null? (cdr l))) #f]
+ [(tag-eq? f (car l)) (cadr l)]
+ [else (loop (cdr l))])))
+ flags)))
- (define (imap-messages imap)
- (imap-exists imap))
-
- (define (imap-disconnect imap)
- (let ([r (imap-r imap)]
- [w (imap-w imap)])
- (check-ok (imap-send imap "LOGOUT" void))
- (close-input-port r)
- (close-output-port w)))
+ (define (imap-poll imap)
+ (when (and ;; Check for async messages from the server
+ (char-ready? (imap-r imap))
+ ;; It has better start with "*"...
+ (= (peek-byte (imap-r imap)) (char->integer #\*)))
+ ;; May set fields in `imap':
+ (get-response (imap-r imap) #f (wrap-info-handler imap void) null)
+ (void)))
- (define (imap-force-disconnect imap)
- (let ([r (imap-r imap)]
- [w (imap-w imap)])
- (close-input-port r)
- (close-output-port w)))
-
- (define (no-expunges who imap)
- (unless (tree-empty? (imap-expunges imap))
- (raise-mismatch-error who
- "session has pending expunge reports: "
- imap)))
+ (define (imap-get-updates imap)
+ (no-expunges 'imap-updates imap)
+ (let ([l (fetch-tree->list (imap-fetches imap))])
+ (set-imap-fetches! imap (new-tree))
+ l))
- (define (imap-get-messages imap msgs field-list)
- (no-expunges 'imap-get-messages imap)
- (when (or (not (list? msgs))
- (not (andmap integer? msgs)))
- (raise-type-error 'imap-get-messages "non-empty message list" msgs))
- (when (or (null? field-list)
- (not (list? field-list))
- (not (andmap (lambda (f) (assoc f field-names)) field-list)))
- (raise-type-error 'imap-get-messages "non-empty field list" field-list))
-
- (if (null? msgs)
- null
- (begin
- ;; FETCH request adds info to `(imap-fectches imap)':
- (imap-send imap (list "FETCH"
- (box (splice msgs ","))
- (box
- (format "(~a)"
- (splice (map (lambda (f) (cadr (assoc f field-names))) field-list) " "))))
- void)
- ;; Sort out the collected info:
- (let ([flds (map (lambda (f)
- (cadr (assoc f field-names)))
- field-list)])
- (begin0
- ;; For each msg, try to get each field value:
- (map
- (lambda (msg)
- (let ([m (or (fetch-find (imap-fetches imap) msg)
- (error 'imap-get-messages "no result for message ~a" msg))])
- (let loop ([flds flds][m (cdr m)])
- (cond
- [(null? flds)
- (if (null? m)
- (fetch-delete! (imap-fetches imap) msg)
- (fetch-insert! (imap-fetches imap) (cons msg m)))
- null]
- [else
- (let ([a (assoc (car flds) m)])
- (cons
- (and a (cdr a))
- (loop (cdr flds) (if a
- (remq a m)
- m))))]))))
- msgs))))))
-
- (define (imap-store imap mode msgs flags)
- (no-expunges 'imap-store imap)
- (check-ok
- (imap-send imap
- (list "STORE"
- (box (splice msgs ","))
- (case mode
- [(+) "+FLAGS.SILENT"]
- [(-) "-FLAGS.SILENT"]
- [(!) "FLAGS.SILENT"]
- [else (raise-type-error
- 'imap-store
- "mode: '!, '+, or '-"
- mode)])
- (box (format "~a" flags)))
- void)))
+ (define (imap-pending-updates? imap)
+ (not (tree-empty? (imap-fetches imap))))
- (define (imap-copy imap msgs dest-mailbox)
- (no-expunges 'imap-copy imap)
- (check-ok
- (imap-send imap
- (list "COPY"
- (box (splice msgs ","))
- dest-mailbox)
- void)))
-
- (define (imap-append imap dest-mailbox msg)
- (no-expunges 'imap-append imap)
- (let ([msg (if (bytes? msg)
- msg
- (string->bytes/utf-8 msg))])
- (check-ok
- (imap-send imap (list "APPEND"
- dest-mailbox
- (box "(\\Seen)")
- (box (format "{~a}" (bytes-length msg))))
- void
- (lambda (loop contin)
- (fprintf (imap-w imap) "~a\r\n" msg)
- (loop))))))
-
- (define (imap-expunge imap)
- (check-ok (imap-send imap "EXPUNGE" void)))
-
- (define (imap-mailbox-exists? imap mailbox)
- (let ([exists? #f])
- (check-ok (imap-send imap
- (list "LIST"
- ""
- mailbox)
- (lambda (i)
- (when (and (pair? i)
- (tag-eq? (car i) 'LIST))
- (set! exists? #t)))))
- exists?))
+ (define (imap-get-expunges imap)
+ (let ([l (expunge-tree->list (imap-expunges imap))])
+ (set-imap-expunges! imap (new-tree))
+ l))
- (define (imap-create-mailbox imap mailbox)
- (check-ok
- (imap-send imap
- (list "CREATE" mailbox)
- void)))
-
- (define (imap-get-hierarchy-delimiter imap)
- (let* ([result #f])
- (check-ok
- (imap-send imap (list "LIST" "" "")
- (lambda (i)
- (when (and (pair? i)
- (tag-eq? (car i) 'LIST))
- (set! result (caddr i))))))
- result))
+ (define (imap-pending-expunges? imap)
+ (not (tree-empty? (imap-expunges imap))))
- (define imap-list-child-mailboxes
- (case-lambda
- [(imap mailbox)
- (imap-list-child-mailboxes imap mailbox #f)]
- [(imap mailbox raw-delimiter)
- (let* ([delimiter (or raw-delimiter (imap-get-hierarchy-delimiter imap))]
- [mailbox-name (and mailbox (bytes-append mailbox delimiter))]
- [pattern (if mailbox
- (bytes-append mailbox-name #"%")
- #"%")])
- (map (lambda (p)
- (list (car p)
- (cond
- [(symbol? (cadr p)) (string->bytes/utf-8 (symbol->string (cadr p)))]
- [(string? (cadr p)) (string->bytes/utf-8 (symbol->string (cadr p)))]
- [(bytes? (cadr p)) (cadr p)])))
- (imap-list-mailboxes imap pattern mailbox-name)))]))
-
- (define (imap-mailbox-flags imap mailbox)
- (let ([r (imap-list-mailboxes imap mailbox #f)])
- (if (= (length r) 1)
- (caar r)
- (error 'imap-mailbox-flags "could not get flags for ~s (~a)"
- mailbox
- (if (null? r) "no matches" "multiple matches")))))
-
- (define (imap-list-mailboxes imap pattern except)
- (let* ([sub-folders null])
- (check-ok
- (imap-send imap (list "LIST" "" pattern)
- (lambda (x)
- (when (and (pair? x)
- (tag-eq? (car x) 'LIST))
- (let* ([flags (cadr x)]
- [name (cadddr x)]
- [bytes-name (if (symbol? name)
- (string->bytes/utf-8 (symbol->string name))
- name)])
- (unless (and except
- (bytes=? bytes-name except))
- (set! sub-folders
- (cons
- (list flags name)
- sub-folders))))))))
- (reverse sub-folders))))
+ (define (imap-reset-new! imap)
+ (set-imap-new?! imap #f))
+
+ (define (imap-messages imap)
+ (imap-exists imap))
+
+ (define (imap-disconnect imap)
+ (let ([r (imap-r imap)]
+ [w (imap-w imap)])
+ (check-ok (imap-send imap "LOGOUT" void))
+ (close-input-port r)
+ (close-output-port w)))
+
+ (define (imap-force-disconnect imap)
+ (let ([r (imap-r imap)]
+ [w (imap-w imap)])
+ (close-input-port r)
+ (close-output-port w)))
+
+ (define (no-expunges who imap)
+ (unless (tree-empty? (imap-expunges imap))
+ (raise-mismatch-error who "session has pending expunge reports: " imap)))
+
+ (define (imap-get-messages imap msgs field-list)
+ (no-expunges 'imap-get-messages imap)
+ (when (or (not (list? msgs))
+ (not (andmap integer? msgs)))
+ (raise-type-error 'imap-get-messages "non-empty message list" msgs))
+ (when (or (null? field-list)
+ (not (list? field-list))
+ (not (andmap (lambda (f) (assoc f field-names)) field-list)))
+ (raise-type-error 'imap-get-messages "non-empty field list" field-list))
+
+ (if (null? msgs)
+ null
+ (begin
+ ;; FETCH request adds info to `(imap-fectches imap)':
+ (imap-send imap
+ (list "FETCH"
+ (box (splice msgs ","))
+ (box
+ (format "(~a)"
+ (splice (map (lambda (f)
+ (cadr (assoc f field-names)))
+ field-list)
+ " "))))
+ void)
+ ;; Sort out the collected info:
+ (let ([flds (map (lambda (f) (cadr (assoc f field-names)))
+ field-list)])
+ (begin0
+ ;; For each msg, try to get each field value:
+ (map
+ (lambda (msg)
+ (let ([m (or (fetch-find (imap-fetches imap) msg)
+ (error 'imap-get-messages "no result for message ~a" msg))])
+ (let loop ([flds flds][m (cdr m)])
+ (cond
+ [(null? flds)
+ (if (null? m)
+ (fetch-delete! (imap-fetches imap) msg)
+ (fetch-insert! (imap-fetches imap) (cons msg m)))
+ null]
+ [else
+ (let ([a (assoc (car flds) m)])
+ (cons (and a (cdr a))
+ (loop (cdr flds) (if a (remq a m) m))))]))))
+ msgs))))))
+
+ (define (imap-store imap mode msgs flags)
+ (no-expunges 'imap-store imap)
+ (check-ok
+ (imap-send imap
+ (list "STORE"
+ (box (splice msgs ","))
+ (case mode
+ [(+) "+FLAGS.SILENT"]
+ [(-) "-FLAGS.SILENT"]
+ [(!) "FLAGS.SILENT"]
+ [else (raise-type-error
+ 'imap-store "mode: '!, '+, or '-" mode)])
+ (box (format "~a" flags)))
+ void)))
+
+ (define (imap-copy imap msgs dest-mailbox)
+ (no-expunges 'imap-copy imap)
+ (check-ok
+ (imap-send imap (list "COPY" (box (splice msgs ",")) dest-mailbox)
+ void)))
+
+ (define (imap-append imap dest-mailbox msg)
+ (no-expunges 'imap-append imap)
+ (let ([msg (if (bytes? msg)
+ msg
+ (string->bytes/utf-8 msg))])
+ (check-ok
+ (imap-send imap (list "APPEND"
+ dest-mailbox
+ (box "(\\Seen)")
+ (box (format "{~a}" (bytes-length msg))))
+ void
+ (lambda (loop contin)
+ (fprintf (imap-w imap) "~a\r\n" msg)
+ (loop))))))
+
+ (define (imap-expunge imap)
+ (check-ok (imap-send imap "EXPUNGE" void)))
+
+ (define (imap-mailbox-exists? imap mailbox)
+ (let ([exists? #f])
+ (check-ok (imap-send imap
+ (list "LIST" "" mailbox)
+ (lambda (i)
+ (when (and (pair? i)
+ (tag-eq? (car i) 'LIST))
+ (set! exists? #t)))))
+ exists?))
+
+ (define (imap-create-mailbox imap mailbox)
+ (check-ok (imap-send imap (list "CREATE" mailbox) void)))
+
+ (define (imap-get-hierarchy-delimiter imap)
+ (let* ([result #f])
+ (check-ok
+ (imap-send imap (list "LIST" "" "")
+ (lambda (i)
+ (when (and (pair? i) (tag-eq? (car i) 'LIST))
+ (set! result (caddr i))))))
+ result))
+
+ (define imap-list-child-mailboxes
+ (case-lambda
+ [(imap mailbox)
+ (imap-list-child-mailboxes imap mailbox #f)]
+ [(imap mailbox raw-delimiter)
+ (let* ([delimiter (or raw-delimiter (imap-get-hierarchy-delimiter imap))]
+ [mailbox-name (and mailbox (bytes-append mailbox delimiter))]
+ [pattern (if mailbox
+ (bytes-append mailbox-name #"%")
+ #"%")])
+ (map (lambda (p)
+ (list (car p)
+ (cond
+ [(symbol? (cadr p))
+ (string->bytes/utf-8 (symbol->string (cadr p)))]
+ [(string? (cadr p))
+ (string->bytes/utf-8 (symbol->string (cadr p)))]
+ [(bytes? (cadr p))
+ (cadr p)])))
+ (imap-list-mailboxes imap pattern mailbox-name)))]))
+
+ (define (imap-mailbox-flags imap mailbox)
+ (let ([r (imap-list-mailboxes imap mailbox #f)])
+ (if (= (length r) 1)
+ (caar r)
+ (error 'imap-mailbox-flags "could not get flags for ~s (~a)"
+ mailbox
+ (if (null? r) "no matches" "multiple matches")))))
+
+ (define (imap-list-mailboxes imap pattern except)
+ (let* ([sub-folders null])
+ (check-ok
+ (imap-send imap (list "LIST" "" pattern)
+ (lambda (x)
+ (when (and (pair? x)
+ (tag-eq? (car x) 'LIST))
+ (let* ([flags (cadr x)]
+ [name (cadddr x)]
+ [bytes-name (if (symbol? name)
+ (string->bytes/utf-8 (symbol->string name))
+ name)])
+ (unless (and except
+ (bytes=? bytes-name except))
+ (set! sub-folders
+ (cons (list flags name) sub-folders))))))))
+ (reverse sub-folders))))
diff --git a/collects/net/mime-sig.ss b/collects/net/mime-sig.ss
index 99383d2..9ddb9b2 100644
--- a/collects/net/mime-sig.ss
+++ b/collects/net/mime-sig.ss
@@ -8,7 +8,7 @@
(struct empty-type () -setters -constructor)
(struct empty-subtype () -setters -constructor)
(struct empty-disposition-type () -setters -constructor)
-
+
;; -- basic mime structures --
(struct message (version entity fields))
(struct entity
@@ -20,7 +20,7 @@
(type filename creation
modification read
size params))
-
+
;; -- mime methods --
mime-analyze
)
diff --git a/collects/net/mime-unit.ss b/collects/net/mime-unit.ss
index f0e2d19..1d41833 100644
--- a/collects/net/mime-unit.ss
+++ b/collects/net/mime-unit.ss
@@ -1,8 +1,8 @@
;;;
;;; ---- MIME support
;;;
-;;; Copyright (C) 2002 by PLT.
-;;; Copyright (C) 2001 by Wish Computing.
+;;; Copyright (C) 2002 by PLT.
+;;; Copyright (C) 2001 by Wish Computing.
;;;
;;; This file is part of mime
@@ -31,7 +31,7 @@
(require "mime-sig.ss"
"qp-sig.ss"
"base64-sig.ss"
- "head-sig.ss"
+ "head-sig.ss"
"mime-util.ss"
(lib "etc.ss")
(lib "string.ss")
@@ -40,742 +40,740 @@
(import base64^ qp^ head^)
(export mime^)
- ;; Constants:
- (define discrete-alist '(("text" . text)
- ("image" . image)
- ("audio" . audio)
- ("video" . video)
- ("application" . application)))
+ ;; Constants:
+ (define discrete-alist
+ '(("text" . text)
+ ("image" . image)
+ ("audio" . audio)
+ ("video" . video)
+ ("application" . application)))
- (define disposition-alist '(("inline" . inline)
- ("attachment" . attachment)
- ("file" . attachment) ;; This is used
- ;; (don't know why)
- ;; by multipart/form-data
- ("messagetext" . inline)
- ("form-data" . form-data)))
+ (define disposition-alist
+ '(("inline" . inline)
+ ("attachment" . attachment)
+ ("file" . attachment) ;; This is used (don't know why) by
+ ;; multipart/form-data
+ ("messagetext" . inline)
+ ("form-data" . form-data)))
- (define composite-alist '(("message" . message)
- ("multipart" . multipart)))
-
- (define mechanism-alist '(("7bit" . 7bit)
- ("8bit" . 8bit)
- ("binary" . binary)
- ("quoted-printable" . quoted-printable)
- ("base64" . base64)))
-
- (define ietf-extensions '())
- (define iana-extensions '(;; text
- ("plain" . plain)
- ("html" . html)
- ("enriched" . enriched) ; added 5/2005 - probably not iana
- ("richtext" . richtext)
- ("tab-separated-values" . tab-separated-values)
- ;; Multipart
- ("mixed" . mixed)
- ("alternative" . alternative)
- ("digest" . digest)
- ("parallel" . parallel)
- ("appledouble" . appledouble)
- ("header-set" . header-set)
- ("form-data" . form-data)
- ;; Message
- ("rfc822" . rfc822)
- ("partial" . partial)
- ("external-body" . external-body)
- ("news" . news)
- ;; Application
- ("octet-stream" . octet-stream)
- ("postscript" . postscript)
- ("oda" . oda)
- ("atomicmail" . atomicmail)
- ("andrew-inset" . andrew-inset)
- ("slate" . slate)
- ("wita" . wita)
- ("dec-dx" . dec-dx)
- ("dca-rf" . dca-rf)
- ("activemessage" . activemessage)
- ("rtf" . rtf)
- ("applefile" . applefile)
- ("mac-binhex40" . mac-binhex40)
- ("news-message-id" . news-message-id)
- ("news-transmissio" . news-transmissio)
- ("wordperfect5.1" . wordperfect5.1)
- ("pdf" . pdf)
- ("zip" . zip)
- ("macwritei" . macwritei)
- ;; "image"
- ("jpeg" . jpeg)
- ("gif" . gif)
- ("ief" . ief)
- ("tiff" . tiff)
- ;; "audio"
- ("basic" . basic)
- ;; "video" .
- ("mpeg" . mpeg)
- ("quicktime" . quicktime)))
+ (define composite-alist
+ '(("message" . message)
+ ("multipart" . multipart)))
- ;; Basic structures
- (define-struct message (version entity fields))
- (define-struct entity
- (type subtype charset encoding disposition params id description other fields parts body))
- (define-struct disposition
- (type filename creation modification read size params))
+ (define mechanism-alist
+ '(("7bit" . 7bit)
+ ("8bit" . 8bit)
+ ("binary" . binary)
+ ("quoted-printable" . quoted-printable)
+ ("base64" . base64)))
- ;; Exceptions
- (define-struct mime-error ())
- (define-struct (unexpected-termination mime-error) (msg))
- (define-struct (missing-multipart-boundary-parameter mime-error) ())
- (define-struct (malformed-multipart-entity mime-error) (msg))
- (define-struct (empty-mechanism mime-error) ())
- (define-struct (empty-type mime-error) ())
- (define-struct (empty-subtype mime-error) ())
- (define-struct (empty-disposition-type mime-error) ())
+ (define ietf-extensions '())
+ (define iana-extensions
+ '(;; text
+ ("plain" . plain)
+ ("html" . html)
+ ("enriched" . enriched) ; added 5/2005 - probably not iana
+ ("richtext" . richtext)
+ ("tab-separated-values" . tab-separated-values)
+ ;; Multipart
+ ("mixed" . mixed)
+ ("alternative" . alternative)
+ ("digest" . digest)
+ ("parallel" . parallel)
+ ("appledouble" . appledouble)
+ ("header-set" . header-set)
+ ("form-data" . form-data)
+ ;; Message
+ ("rfc822" . rfc822)
+ ("partial" . partial)
+ ("external-body" . external-body)
+ ("news" . news)
+ ;; Application
+ ("octet-stream" . octet-stream)
+ ("postscript" . postscript)
+ ("oda" . oda)
+ ("atomicmail" . atomicmail)
+ ("andrew-inset" . andrew-inset)
+ ("slate" . slate)
+ ("wita" . wita)
+ ("dec-dx" . dec-dx)
+ ("dca-rf" . dca-rf)
+ ("activemessage" . activemessage)
+ ("rtf" . rtf)
+ ("applefile" . applefile)
+ ("mac-binhex40" . mac-binhex40)
+ ("news-message-id" . news-message-id)
+ ("news-transmissio" . news-transmissio)
+ ("wordperfect5.1" . wordperfect5.1)
+ ("pdf" . pdf)
+ ("zip" . zip)
+ ("macwritei" . macwritei)
+ ;; "image"
+ ("jpeg" . jpeg)
+ ("gif" . gif)
+ ("ief" . ief)
+ ("tiff" . tiff)
+ ;; "audio"
+ ("basic" . basic)
+ ;; "video" .
+ ("mpeg" . mpeg)
+ ("quicktime" . quicktime)))
- ;; *************************************
- ;; Practical stuff, aka MIME in action:
- ;; *************************************
- (define CRLF (format "~a~a" #\return #\newline))
- (define CRLF-binary "=0D=0A") ;; quoted printable representation
+ ;; Basic structures
+ (define-struct message (version entity fields))
+ (define-struct entity
+ (type subtype charset encoding disposition params id description other
+ fields parts body))
+ (define-struct disposition
+ (type filename creation modification read size params))
- ;; get-headers : input-port -> string
- ;; returns the header part of a message/part conforming to rfc822,
- ;; and rfc2045.
- (define get-headers
- (lambda (in)
- (let loop ((headers "") (ln (read-line in 'any)))
- (cond ((eof-object? ln)
- ;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
- (warning "premature eof while parsing headers")
- headers)
- ((string=? ln "") headers)
- (else
- ;; Quoting rfc822:
- ;; " Headers occur before the message body and are
- ;; terminated by a null line (i.e., two contiguous
- ;; CRLFs)."
- ;; That is: Two empty lines. But most MUAs seem to count
- ;; the CRLF ending the last field (header) as the first
- ;; CRLF of the null line.
- (loop (string-append headers ln CRLF)
- (read-line in 'any)))))))
-
- (define make-default-disposition
- (lambda ()
- (make-disposition
- 'inline ;; type
- "" ;; filename
- #f ;; creation
- #f ;; modification
- #f ;; read
- #f ;; size
- null ;; params
- )))
-
- (define make-default-entity
- (lambda ()
- (make-entity
- 'text ;; type
- 'plain ;; subtype
- 'us-ascii ;; charset
- '7bit ;; encoding
- (make-default-disposition) ;; disposition
- null ;; params
- "" ;; id
- "" ;; description
- null ;; other MIME fields (MIME-extension-fields)
- null ;; fields
- null ;; parts
- null ;; body
- )))
-
- (define make-default-message
- (lambda ()
- (make-message 1.0 (make-default-entity) null)))
-
- (define mime-decode
- (lambda (entity input)
- (set-entity-body!
- entity
- (case (entity-encoding entity)
- ((quoted-printable)
- (lambda (output)
- (qp-decode-stream input output)))
- ((base64)
- (lambda (output)
- (base64-decode-stream input output)))
- (else ;; 7bit, 8bit, binary
- (lambda (output)
- (copy-port input output)))))))
+ ;; Exceptions
+ (define-struct mime-error ())
+ (define-struct (unexpected-termination mime-error) (msg))
+ (define-struct (missing-multipart-boundary-parameter mime-error) ())
+ (define-struct (malformed-multipart-entity mime-error) (msg))
+ (define-struct (empty-mechanism mime-error) ())
+ (define-struct (empty-type mime-error) ())
+ (define-struct (empty-subtype mime-error) ())
+ (define-struct (empty-disposition-type mime-error) ())
- (define mime-analyze
- (opt-lambda (input (part #f))
- (let* ((iport (if (bytes? input)
- (open-input-bytes input)
- input))
- (headers (get-headers iport))
- (msg (if part
- (MIME-part-headers headers)
- (MIME-message-headers headers)))
- (entity (message-entity msg)))
- ;; OK we have in msg a MIME-message structure, lets see what we have:
- (case (entity-type entity)
- ((text image audio video application)
- ;; decode part, and save port and thunk
- (mime-decode entity iport))
- ((message multipart)
- (let ((boundary (entity-boundary entity)))
- (when (not boundary)
- (if (eq? 'multipart (entity-type entity))
- (raise (make-missing-multipart-boundary-parameter))))
- (set-entity-parts! entity
- (map (lambda (part)
- (mime-analyze part #t))
- (if boundary
- (multipart-body iport boundary)
- (list iport))))))
- (else
- ;; Unrecognized type, you're on your own! (sorry)
- (mime-decode entity iport)))
- ;; return mime structure
- msg)))
-
-
- (define entity-boundary
- (lambda (entity)
- (let* ((params (entity-params entity))
- (ans (assoc "boundary" params)))
- (and ans
- (cdr ans)))))
-
- ;; *************************************************
- ;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
- ;; *************************************************
-
- ;;multipart-body := [preamble CRLF]
- ;; dash-boundary transport-padding CRLF
- ;; body-part *encapsulation
- ;; close-delimiter transport-padding
- ;; [CRLF epilogue]
- ;; Returns a list of input ports, each one containing the correspongind part.
- (define multipart-body
- (lambda (input boundary)
- (let* ([make-re (lambda (prefix)
- (regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
- [re (make-re "\r\n")])
- (letrec ((eat-part (lambda ()
- (let-values ([(pin pout) (make-pipe)])
- (let ([m (regexp-match re input 0 #f pout)])
- (cond
- [(not m)
- (close-output-port pout)
- (values pin;; part
- #f;; close-delimiter?
- #t;; eof reached?
- )]
- [(cadr m)
- (close-output-port pout)
- (values pin #t #f)]
- [else
- (close-output-port pout)
- (values pin #f #f)]))))))
- ;; pre-amble is allowed to be completely empty:
- (if (regexp-match-peek (make-re "^") input)
- ;; No \r\f before first separator:
- (read-line input)
- ;; non-empty preamble:
- (eat-part))
- (let loop ()
- (let-values ([(part close? eof?) (eat-part)])
- (cond (close? (list part))
- (eof? (list part))
- (else
- (cons part (loop))))))))))
-
- ;; MIME-message-headers := entity-headers
- ;; fields
- ;; version CRLF
- ;; ; The ordering of the header
- ;; ; fields implied by this BNF
- ;; ; definition should be ignored.
- (define MIME-message-headers
- (lambda (headers)
- (let ((message (make-default-message)))
- (entity-headers headers message #t)
- message)))
-
- ;; MIME-part-headers := entity-headers
- ;; [ fields ]
- ;; ; Any field not beginning with
- ;; ; "content-" can have no defined
- ;; ; meaning and may be ignored.
- ;; ; The ordering of the header
- ;; ; fields implied by this BNF
- ;; ; definition should be ignored.
- (define MIME-part-headers
- (lambda (headers)
- (let ((message (make-default-message)))
- (entity-headers headers message #f)
- message)))
-
- ;; entity-headers := [ content CRLF ]
- ;; [ encoding CRLF ]
- ;; [ id CRLF ]
- ;; [ description CRLF ]
- ;; *( MIME-extension-field CRLF )
- (define entity-headers
- (lambda (headers message version?)
- (let ((entity (message-entity message)))
- (let-values ([(mime non-mime) (get-fields headers)])
- (let loop ((fields mime))
- (unless (null? fields)
- ;; Process MIME field
- (let ((trimmed-h (trim-comments (car fields))))
- (or (and version? (version trimmed-h message))
- (content trimmed-h entity)
- (encoding trimmed-h entity)
- (dispositione trimmed-h entity)
- (id trimmed-h entity)
- (description trimmed-h entity)
- (MIME-extension-field trimmed-h entity))
- ;; keep going
- (loop (cdr fields)))))
- ;; NON-mime headers (or semantically incorrect). In
- ;; order to make this implementation of rfc2045 robuts,
- ;; we will save the header in the fields field of the
- ;; message struct:
- (set-message-fields! message non-mime)
- ;; Return message
- message))))
-
- (define get-fields
- (lambda (headers)
- (let ((mime null) (non-mime null))
- (letrec ((store-field
- (lambda (f)
- (unless (string=? f "")
- (if (mime-header? f)
- (set! mime (append mime (list (trim-spaces f))))
- (set! non-mime (append non-mime (list (trim-spaces f)))))))))
- (let ([fields (extract-all-fields headers)])
- (for-each (lambda (p)
- (store-field (format "~a: ~a" (car p) (cdr p))))
- fields))
- (values mime non-mime)))))
-
- (define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
- (define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
+ ;; *************************************
+ ;; Practical stuff, aka MIME in action:
+ ;; *************************************
+ (define CRLF (format "~a~a" #\return #\newline))
+ (define CRLF-binary "=0D=0A") ;; quoted printable representation
- (define mime-header?
- (lambda (h)
- (or (regexp-match re:content h)
- (regexp-match re:mime h))))
-
-
- ;;; Headers
- ;;; Content-type follows this BNF syntax:
- ;; content := "Content-Type" ":" type "/" subtype
- ;; *(";" parameter)
- ;; ; Matching of media type and subtype
- ;; ; is ALWAYS case-insensitive.
- (define re:content-type (regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
- (define content
- (lambda (header entity)
- (let* ((params (string-tokenizer #\; header))
- (one re:content-type)
- (h (trim-all-spaces (car params)))
- (target (regexp-match one h))
- (old-param (entity-params entity)))
- (and target
- (set-entity-type! entity
- (type (regexp-replace one h "\\1"))) ;; type
- (set-entity-subtype! entity
- (subtype (regexp-replace one h "\\2"))) ;; subtype
- (set-entity-params!
- entity
- (append old-param
- (let loop ((p (cdr params));; parameters
- (ans null))
- (cond ((null? p) ans)
- (else
- (let ((par-pair (parameter (trim-all-spaces (car p)))))
- (cond (par-pair
- (when (string=? (car par-pair) "charset")
- (set-entity-charset! entity (cdr par-pair)))
- (loop (cdr p)
- (append ans
- (list par-pair))))
- (else
- (warning "Invalid parameter for Content-Type: `~a'" (car p))
- ;; go on...
- (loop (cdr p) ans)))))))))))))
-
- ;; From rfc2183 Content-Disposition
- ;; disposition := "Content-Disposition" ":"
- ;; disposition-type
- ;; *(";" disposition-parm)
- (define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
- (define dispositione
- (lambda (header entity)
- (let* ((params (string-tokenizer #\; header))
- (reg re:content-disposition)
- (h (trim-all-spaces (car params)))
- (target (regexp-match reg h))
- (disp-struct (entity-disposition entity)))
- (and target
- (set-disposition-type!
- disp-struct
- (disp-type (regexp-replace reg h "\\1")))
- (disp-params (cdr params) disp-struct)))))
-
- ;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
- (define re:mime-version (regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
- (define version
- (lambda (header message)
- (let* ((reg re:mime-version)
- (h (trim-all-spaces header))
- (target (regexp-match reg h)))
- (and target
- (set-message-version!
- message
- (string->number (regexp-replace reg h "\\1.\\2")))))))
-
- ;; description := "Content-Description" ":" *text
- (define re:content-description (regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
- (define description
- (lambda (header entity)
- (let* ((reg re:content-description)
- (target (regexp-match reg header)))
- (and target
- (set-entity-description!
- entity
- (trim-spaces (regexp-replace reg header "\\1")))))))
-
- ;; encoding := "Content-Transfer-Encoding" ":" mechanism
- (define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
- (define encoding
- (lambda (header entity)
- (let* ((reg re:content-transfer-encoding)
- (h (trim-all-spaces header))
- (target (regexp-match reg h)))
- (and target
- (set-entity-encoding!
- entity
- (mechanism (regexp-replace reg h "\\1")))))))
-
- ;; id := "Content-ID" ":" msg-id
- (define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
- (define id
- (lambda (header entity)
- (let* ((reg re:content-id)
- (h (trim-all-spaces header))
- (target (regexp-match reg h)))
- (and target
- (set-entity-id!
- entity
- (msg-id (regexp-replace reg h "\\1")))))))
-
- ;; From rfc822:
- ;; msg-id = "<" addr-spec ">" ; Unique message id
- ;; addr-spec = local-part "@" domain ; global address
- ;; local-part = word *("." word) ; uninterpreted
- ;; ; case-preserved
- ;; domain = sub-domain *("." sub-domain)
- ;; sub-domain = domain-ref / domain-literal
- ;; domain-literal = "[" *(dtext / quoted-pair) "]"
- ;; domain-ref = atom ; symbolic reference
- (define msg-id
- (lambda (str)
- (let* ((r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$"))
- (ans (regexp-match r str)))
- (if ans
- str
- (begin (warning "Invalid msg-id: ~a" str)
- str)))))
-
- ;; mechanism := "7bit" / "8bit" / "binary" /
- ;; "quoted-printable" / "base64" /
- ;; ietf-token / x-token
- (define mechanism
- (lambda (mech)
- (if (not mech)
- (raise (make-empty-mechanism))
- (let ((val (assoc (lowercase mech) mechanism-alist)))
- (or (and val (cdr val))
- (ietf-token mech)
- (x-token mech))))))
-
- ;; MIME-extension-field :=
- ;;
- (define MIME-extension-field
- (lambda (header entity)
- (let* ((reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$"))
- (target (regexp-match reg header)))
- (and target
- (set-entity-other!
- entity
- (append (entity-other entity)
- (list
- (cons (regexp-replace reg header "\\1")
- (trim-spaces (regexp-replace reg header "\\2"))))))))))
-
- ;; type := discrete-type / composite-type
- (define type
- (lambda (value)
- (if (not value)
- (raise (make-empty-type))
- (or (discrete-type value)
- (composite-type value)))))
-
- ;; disposition-type := "inline" / "attachment" / extension-token
- (define disp-type
- (lambda (value)
- (if (not value)
- (raise (make-empty-disposition-type))
- (let ((val (assoc (lowercase (trim-spaces value)) disposition-alist)))
- (if val (cdr val) (extension-token value))))))
-
- ;; discrete-type := "text" / "image" / "audio" / "video" /
- ;; "application" / extension-token
- (define discrete-type
- (lambda (value)
- (let ((val (assoc (lowercase (trim-spaces value)) discrete-alist)))
- (if val (cdr val) (extension-token value)))))
-
- ;; composite-type := "message" / "multipart" / extension-token
- (define composite-type
- (lambda (value)
- (let ((val (assoc (lowercase (trim-spaces value)) composite-alist)))
- (if val (cdr val) (extension-token value)))))
-
- ;; extension-token := ietf-token / x-token
- (define extension-token
- (lambda (value)
- (or (ietf-token value)
- (x-token value))))
-
- ;; ietf-token :=
- (define ietf-token
- (lambda (value)
- (let ((ans (assoc (lowercase (trim-spaces value)) ietf-extensions)))
- (and ans
- (cdr ans)))))
-
- ;; Directly from RFC 1700:
- ;; Type Subtype Description Reference
- ;; ---- ------- ----------- ---------
- ;; text plain [RFC1521,NSB]
- ;; richtext [RFC1521,NSB]
- ;; tab-separated-values [Paul Lindner]
- ;;
- ;; multipart mixed [RFC1521,NSB]
- ;; alternative [RFC1521,NSB]
- ;; digest [RFC1521,NSB]
- ;; parallel [RFC1521,NSB]
- ;; appledouble [MacMime,Patrik Faltstrom]
- ;; header-set [Dave Crocker]
- ;;
- ;; message rfc822 [RFC1521,NSB]
- ;; partial [RFC1521,NSB]
- ;; external-body [RFC1521,NSB]
- ;; news [RFC 1036, Henry Spencer]
- ;;
- ;; application octet-stream [RFC1521,NSB]
- ;; postscript [RFC1521,NSB]
- ;; oda [RFC1521,NSB]
- ;; atomicmail [atomicmail,NSB]
- ;; andrew-inset [andrew-inset,NSB]
- ;; slate [slate,terry crowley]
- ;; wita [Wang Info Transfer,Larry Campbell]
- ;; dec-dx [Digital Doc Trans, Larry Campbell]
- ;; dca-rft [IBM Doc Content Arch, Larry Campbell]
- ;; activemessage [Ehud Shapiro]
- ;; rtf [Paul Lindner]
- ;; applefile [MacMime,Patrik Faltstrom]
- ;; mac-binhex40 [MacMime,Patrik Faltstrom]
- ;; news-message-id [RFC1036, Henry Spencer]
- ;; news-transmission [RFC1036, Henry Spencer]
- ;; wordperfect5.1 [Paul Lindner]
- ;; pdf [Paul Lindner]
- ;; zip [Paul Lindner]
- ;; macwriteii [Paul Lindner]
- ;; msword [Paul Lindner]
- ;; remote-printing [RFC1486,MTR]
- ;;
- ;; image jpeg [RFC1521,NSB]
- ;; gif [RFC1521,NSB]
- ;; ief Image Exchange Format [RFC1314]
- ;; tiff Tag Image File Format [MTR]
- ;;
- ;; audio basic [RFC1521,NSB]
- ;;
- ;; video mpeg [RFC1521,NSB]
- ;; quicktime [Paul Lindner]
-
-
- ;; x-token :=
- (define x-token
- (lambda (value)
- (let* ((r #rx"^[xX]-(.*)")
- (h (trim-spaces value))
- (ans (regexp-match r h)))
- (and ans
- (token (regexp-replace r h "\\1"))
- h))))
-
- ;; subtype := extension-token / iana-token
- (define subtype
- (lambda (value)
- (if (not value)
- (raise (make-empty-subtype))
- (or (extension-token value)
- (iana-token value)))))
-
- ;; iana-token :=
- (define iana-token
- (lambda (value)
- (let ((ans (assoc (lowercase (trim-spaces value)) iana-extensions)))
- (and ans
- (cdr ans)))))
-
- ;; parameter := attribute "=" value
- (define re:parameter (regexp "([^=]+)=(.+)"))
- (define parameter
- (lambda (par)
- (let* ((r re:parameter)
- (att (attribute (regexp-replace r par "\\1")))
- (val (value (regexp-replace r par "\\2"))))
- (if (regexp-match r par)
- (cons (if att (lowercase att) "???") val)
- (cons "???" par)))))
-
- ;; value := token / quoted-string
- (define value
- (lambda (val)
- (or (token val)
- (quoted-string val)
- val)))
+ ;; get-headers : input-port -> string
+ ;; returns the header part of a message/part conforming to rfc822, and
+ ;; rfc2045.
+ (define get-headers
+ (lambda (in)
+ (let loop ([headers ""] [ln (read-line in 'any)])
+ (cond [(eof-object? ln)
+ ;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
+ (warning "premature eof while parsing headers")
+ headers]
+ [(string=? ln "") headers]
+ [else
+ ;; Quoting rfc822:
+ ;; " Headers occur before the message body and are
+ ;; terminated by a null line (i.e., two contiguous
+ ;; CRLFs)."
+ ;; That is: Two empty lines. But most MUAs seem to count
+ ;; the CRLF ending the last field (header) as the first
+ ;; CRLF of the null line.
+ (loop (string-append headers ln CRLF)
+ (read-line in 'any))]))))
- ;; token := 1*
- ;; tspecials := "(" / ")" / "<" / ">" / "@" /
- ;; "," / ";" / ":" / "\" / <">
- ;; "/" / "[" / "]" / "?" / "="
- ;; ; Must be in quoted-string,
- ;; ; to use within parameter values
- (define token
- (lambda (value)
- (let* ((tspecials (regexp "[^][()<>@,;:\\\"/?= ]+"))
- (ans (regexp-match tspecials value)))
- (and ans
- (string=? value (car ans))
- (car ans)))))
-
- ;; attribute := token
- ;; ; Matching of attributes
- ;; ; is ALWAYS case-insensitive.
- (define attribute token)
-
- (define re:quotes (regexp "\"(.+)\""))
- (define quoted-string
- (lambda (str)
- (let* ((quotes re:quotes)
- (ans (regexp-match quotes str)))
- (and ans
- (regexp-replace quotes str "\\1")))))
-
- ;; disposition-parm := filename-parm
- ;; / creation-date-parm
- ;; / modification-date-parm
- ;; / read-date-parm
- ;; / size-parm
- ;; / parameter
- ;;
- ;; filename-parm := "filename" "=" value
- ;;
- ;; creation-date-parm := "creation-date" "=" quoted-date-time
- ;;
- ;; modification-date-parm := "modification-date" "=" quoted-date-time
- ;;
- ;; read-date-parm := "read-date" "=" quoted-date-time
- ;;
- ;; size-parm := "size" "=" 1*DIGIT
- (define disp-params
- (lambda (lst disp)
- (let loop ((lst lst))
- (unless (null? lst)
- (let* ((p (parameter (trim-all-spaces (car lst))))
- (parm (car p))
- (value (cdr p)))
- (cond ((string=? parm "filename")
- (set-disposition-filename! disp value))
- ((string=? parm "creation-date")
- (set-disposition-creation!
- disp
- (disp-quoted-data-time value)))
- ((string=? parm "modification-date")
- (set-disposition-modification!
- disp
- (disp-quoted-data-time value)))
- ((string=? parm "read-date")
- (set-disposition-read!
- disp
- (disp-quoted-data-time value)))
- ((string=? parm "size")
- (set-disposition-size!
- disp
- (string->number value)))
- (else
- (set-disposition-params!
- disp
- (append (disposition-params disp) (list p)))))
- (loop (cdr lst)))))))
-
- ;; date-time = [ day "," ] date time ; dd mm yy
- ;; ; hh:mm:ss zzz
- ;;
- ;; day = "Mon" / "Tue" / "Wed" / "Thu"
- ;; / "Fri" / "Sat" / "Sun"
- ;;
- ;; date = 1*2DIGIT month 2DIGIT ; day month year
- ;; ; e.g. 20 Jun 82
- ;;
- ;; month = "Jan" / "Feb" / "Mar" / "Apr"
- ;; / "May" / "Jun" / "Jul" / "Aug"
- ;; / "Sep" / "Oct" / "Nov" / "Dec"
- ;;
- ;; time = hour zone ; ANSI and Military
- ;;
- ;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT]
- ;; ; 00:00:00 - 23:59:59
- ;;
- ;; zone = "UT" / "GMT" ; Universal Time
- ;; ; North American : UT
- ;; / "EST" / "EDT" ; Eastern: - 5/ - 4
- ;; / "CST" / "CDT" ; Central: - 6/ - 5
- ;; / "MST" / "MDT" ; Mountain: - 7/ - 6
- ;; / "PST" / "PDT" ; Pacific: - 8/ - 7
- ;; / 1ALPHA ; Military: Z = UT;
- ;; ; A:-1; (J not used)
- ;; ; M:-12; N:+1; Y:+12
- ;; / ( ("+" / "-") 4DIGIT ) ; Local differential
- ;; ; hours+min. (HHMM)
- (define date-time
- (lambda (str)
- ;; Fix Me: I have to return a date structure, or time in seconds.
- str))
-
- ;; quoted-date-time := quoted-string
- ;; ; contents MUST be an RFC 822 `date-time'
- ;; ; numeric timezones (+HHMM or -HHMM) MUST be used
-
- (define disp-quoted-data-time date-time)
-
- )
+ (define make-default-disposition
+ (lambda ()
+ (make-disposition
+ 'inline ;; type
+ "" ;; filename
+ #f ;; creation
+ #f ;; modification
+ #f ;; read
+ #f ;; size
+ null ;; params
+ )))
+
+ (define make-default-entity
+ (lambda ()
+ (make-entity
+ 'text ;; type
+ 'plain ;; subtype
+ 'us-ascii ;; charset
+ '7bit ;; encoding
+ (make-default-disposition) ;; disposition
+ null ;; params
+ "" ;; id
+ "" ;; description
+ null ;; other MIME fields (MIME-extension-fields)
+ null ;; fields
+ null ;; parts
+ null ;; body
+ )))
+
+ (define make-default-message
+ (lambda ()
+ (make-message 1.0 (make-default-entity) null)))
+
+ (define mime-decode
+ (lambda (entity input)
+ (set-entity-body!
+ entity
+ (case (entity-encoding entity)
+ [(quoted-printable)
+ (lambda (output)
+ (qp-decode-stream input output))]
+ [(base64)
+ (lambda (output)
+ (base64-decode-stream input output))]
+ [else ;; 7bit, 8bit, binary
+ (lambda (output)
+ (copy-port input output))]))))
+
+ (define mime-analyze
+ (opt-lambda (input (part #f))
+ (let* ([iport (if (bytes? input)
+ (open-input-bytes input)
+ input)]
+ [headers (get-headers iport)]
+ [msg (if part
+ (MIME-part-headers headers)
+ (MIME-message-headers headers))]
+ [entity (message-entity msg)])
+ ;; OK we have in msg a MIME-message structure, lets see what we have:
+ (case (entity-type entity)
+ [(text image audio video application)
+ ;; decode part, and save port and thunk
+ (mime-decode entity iport)]
+ [(message multipart)
+ (let ([boundary (entity-boundary entity)])
+ (when (not boundary)
+ (if (eq? 'multipart (entity-type entity))
+ (raise (make-missing-multipart-boundary-parameter))))
+ (set-entity-parts! entity
+ (map (lambda (part)
+ (mime-analyze part #t))
+ (if boundary
+ (multipart-body iport boundary)
+ (list iport)))))]
+ [else
+ ;; Unrecognized type, you're on your own! (sorry)
+ (mime-decode entity iport)])
+ ;; return mime structure
+ msg)))
+
+ (define entity-boundary
+ (lambda (entity)
+ (let* ([params (entity-params entity)]
+ [ans (assoc "boundary" params)])
+ (and ans (cdr ans)))))
+
+ ;; *************************************************
+ ;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
+ ;; *************************************************
+
+ ;;multipart-body := [preamble CRLF]
+ ;; dash-boundary transport-padding CRLF
+ ;; body-part *encapsulation
+ ;; close-delimiter transport-padding
+ ;; [CRLF epilogue]
+ ;; Returns a list of input ports, each one containing the correspongind part.
+ (define multipart-body
+ (lambda (input boundary)
+ (let* ([make-re (lambda (prefix)
+ (regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
+ [re (make-re "\r\n")])
+ (letrec ([eat-part (lambda ()
+ (let-values ([(pin pout) (make-pipe)])
+ (let ([m (regexp-match re input 0 #f pout)])
+ (cond
+ [(not m)
+ (close-output-port pout)
+ (values pin ;; part
+ #f ;; close-delimiter?
+ #t ;; eof reached?
+ )]
+ [(cadr m)
+ (close-output-port pout)
+ (values pin #t #f)]
+ [else
+ (close-output-port pout)
+ (values pin #f #f)]))))])
+ ;; pre-amble is allowed to be completely empty:
+ (if (regexp-match-peek (make-re "^") input)
+ ;; No \r\f before first separator:
+ (read-line input)
+ ;; non-empty preamble:
+ (eat-part))
+ (let loop ()
+ (let-values ([(part close? eof?) (eat-part)])
+ (cond (close? (list part))
+ (eof? (list part))
+ (else (cons part (loop))))))))))
+
+ ;; MIME-message-headers := entity-headers
+ ;; fields
+ ;; version CRLF
+ ;; ; The ordering of the header
+ ;; ; fields implied by this BNF
+ ;; ; definition should be ignored.
+ (define MIME-message-headers
+ (lambda (headers)
+ (let ([message (make-default-message)])
+ (entity-headers headers message #t)
+ message)))
+
+ ;; MIME-part-headers := entity-headers
+ ;; [ fields ]
+ ;; ; Any field not beginning with
+ ;; ; "content-" can have no defined
+ ;; ; meaning and may be ignored.
+ ;; ; The ordering of the header
+ ;; ; fields implied by this BNF
+ ;; ; definition should be ignored.
+ (define MIME-part-headers
+ (lambda (headers)
+ (let ([message (make-default-message)])
+ (entity-headers headers message #f)
+ message)))
+
+ ;; entity-headers := [ content CRLF ]
+ ;; [ encoding CRLF ]
+ ;; [ id CRLF ]
+ ;; [ description CRLF ]
+ ;; *( MIME-extension-field CRLF )
+ (define entity-headers
+ (lambda (headers message version?)
+ (let ([entity (message-entity message)])
+ (let-values ([(mime non-mime) (get-fields headers)])
+ (let loop ([fields mime])
+ (unless (null? fields)
+ ;; Process MIME field
+ (let ([trimmed-h (trim-comments (car fields))])
+ (or (and version? (version trimmed-h message))
+ (content trimmed-h entity)
+ (encoding trimmed-h entity)
+ (dispositione trimmed-h entity)
+ (id trimmed-h entity)
+ (description trimmed-h entity)
+ (MIME-extension-field trimmed-h entity))
+ ;; keep going
+ (loop (cdr fields)))))
+ ;; NON-mime headers (or semantically incorrect). In order to make
+ ;; this implementation of rfc2045 robuts, we will save the header in
+ ;; the fields field of the message struct:
+ (set-message-fields! message non-mime)
+ ;; Return message
+ message))))
+
+ (define get-fields
+ (lambda (headers)
+ (let ([mime null] [non-mime null])
+ (letrec ([store-field
+ (lambda (f)
+ (unless (string=? f "")
+ (if (mime-header? f)
+ (set! mime (append mime (list (trim-spaces f))))
+ (set! non-mime (append non-mime (list (trim-spaces f)))))))])
+ (let ([fields (extract-all-fields headers)])
+ (for-each (lambda (p)
+ (store-field (format "~a: ~a" (car p) (cdr p))))
+ fields))
+ (values mime non-mime)))))
+
+ (define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
+ (define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
+
+ (define mime-header?
+ (lambda (h)
+ (or (regexp-match re:content h)
+ (regexp-match re:mime h))))
+
+ ;;; Headers
+ ;;; Content-type follows this BNF syntax:
+ ;; content := "Content-Type" ":" type "/" subtype
+ ;; *(";" parameter)
+ ;; ; Matching of media type and subtype
+ ;; ; is ALWAYS case-insensitive.
+ (define re:content-type
+ (regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
+ (define content
+ (lambda (header entity)
+ (let* ([params (string-tokenizer #\; header)]
+ [one re:content-type]
+ [h (trim-all-spaces (car params))]
+ [target (regexp-match one h)]
+ [old-param (entity-params entity)])
+ (and target
+ (set-entity-type! entity
+ (type (regexp-replace one h "\\1"))) ;; type
+ (set-entity-subtype! entity
+ (subtype (regexp-replace one h "\\2"))) ;; subtype
+ (set-entity-params!
+ entity
+ (append old-param
+ (let loop ([p (cdr params)] ;; parameters
+ [ans null])
+ (cond [(null? p) ans]
+ [else
+ (let ([par-pair (parameter (trim-all-spaces (car p)))])
+ (cond [par-pair
+ (when (string=? (car par-pair) "charset")
+ (set-entity-charset! entity (cdr par-pair)))
+ (loop (cdr p)
+ (append ans
+ (list par-pair)))]
+ [else
+ (warning "Invalid parameter for Content-Type: `~a'" (car p))
+ ;; go on...
+ (loop (cdr p) ans)]))]))))))))
+
+ ;; From rfc2183 Content-Disposition
+ ;; disposition := "Content-Disposition" ":"
+ ;; disposition-type
+ ;; *(";" disposition-parm)
+ (define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
+ (define dispositione
+ (lambda (header entity)
+ (let* ([params (string-tokenizer #\; header)]
+ [reg re:content-disposition]
+ [h (trim-all-spaces (car params))]
+ [target (regexp-match reg h)]
+ [disp-struct (entity-disposition entity)])
+ (and target
+ (set-disposition-type!
+ disp-struct
+ (disp-type (regexp-replace reg h "\\1")))
+ (disp-params (cdr params) disp-struct)))))
+
+ ;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
+ (define re:mime-version
+ (regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
+ (define version
+ (lambda (header message)
+ (let* ([reg re:mime-version]
+ [h (trim-all-spaces header)]
+ [target (regexp-match reg h)])
+ (and target
+ (set-message-version!
+ message
+ (string->number (regexp-replace reg h "\\1.\\2")))))))
+
+ ;; description := "Content-Description" ":" *text
+ (define re:content-description
+ (regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
+ (define description
+ (lambda (header entity)
+ (let* ([reg re:content-description]
+ [target (regexp-match reg header)])
+ (and target
+ (set-entity-description!
+ entity
+ (trim-spaces (regexp-replace reg header "\\1")))))))
+
+ ;; encoding := "Content-Transfer-Encoding" ":" mechanism
+ (define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
+ (define encoding
+ (lambda (header entity)
+ (let* ([reg re:content-transfer-encoding]
+ [h (trim-all-spaces header)]
+ [target (regexp-match reg h)])
+ (and target
+ (set-entity-encoding!
+ entity
+ (mechanism (regexp-replace reg h "\\1")))))))
+
+ ;; id := "Content-ID" ":" msg-id
+ (define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
+ (define id
+ (lambda (header entity)
+ (let* ([reg re:content-id]
+ [h (trim-all-spaces header)]
+ [target (regexp-match reg h)])
+ (and target
+ (set-entity-id!
+ entity
+ (msg-id (regexp-replace reg h "\\1")))))))
+
+ ;; From rfc822:
+ ;; msg-id = "<" addr-spec ">" ; Unique message id
+ ;; addr-spec = local-part "@" domain ; global address
+ ;; local-part = word *("." word) ; uninterpreted
+ ;; ; case-preserved
+ ;; domain = sub-domain *("." sub-domain)
+ ;; sub-domain = domain-ref / domain-literal
+ ;; domain-literal = "[" *(dtext / quoted-pair) "]"
+ ;; domain-ref = atom ; symbolic reference
+ (define msg-id
+ (lambda (str)
+ (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
+ [ans (regexp-match r str)])
+ (if ans
+ str
+ (begin (warning "Invalid msg-id: ~a" str) str)))))
+
+ ;; mechanism := "7bit" / "8bit" / "binary" /
+ ;; "quoted-printable" / "base64" /
+ ;; ietf-token / x-token
+ (define mechanism
+ (lambda (mech)
+ (if (not mech)
+ (raise (make-empty-mechanism))
+ (let ([val (assoc (lowercase mech) mechanism-alist)])
+ (or (and val (cdr val))
+ (ietf-token mech)
+ (x-token mech))))))
+
+ ;; MIME-extension-field :=
+ ;;
+ (define MIME-extension-field
+ (lambda (header entity)
+ (let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
+ [target (regexp-match reg header)])
+ (and target
+ (set-entity-other!
+ entity
+ (append (entity-other entity)
+ (list
+ (cons (regexp-replace reg header "\\1")
+ (trim-spaces (regexp-replace reg header "\\2"))))))))))
+
+ ;; type := discrete-type / composite-type
+ (define type
+ (lambda (value)
+ (if (not value)
+ (raise (make-empty-type))
+ (or (discrete-type value)
+ (composite-type value)))))
+
+ ;; disposition-type := "inline" / "attachment" / extension-token
+ (define disp-type
+ (lambda (value)
+ (if (not value)
+ (raise (make-empty-disposition-type))
+ (let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
+ (if val (cdr val) (extension-token value))))))
+
+ ;; discrete-type := "text" / "image" / "audio" / "video" /
+ ;; "application" / extension-token
+ (define discrete-type
+ (lambda (value)
+ (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
+ (if val (cdr val) (extension-token value)))))
+
+ ;; composite-type := "message" / "multipart" / extension-token
+ (define composite-type
+ (lambda (value)
+ (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
+ (if val (cdr val) (extension-token value)))))
+
+ ;; extension-token := ietf-token / x-token
+ (define extension-token
+ (lambda (value)
+ (or (ietf-token value)
+ (x-token value))))
+
+ ;; ietf-token :=
+ (define ietf-token
+ (lambda (value)
+ (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
+ (and ans (cdr ans)))))
+
+ ;; Directly from RFC 1700:
+ ;; Type Subtype Description Reference
+ ;; ---- ------- ----------- ---------
+ ;; text plain [RFC1521,NSB]
+ ;; richtext [RFC1521,NSB]
+ ;; tab-separated-values [Paul Lindner]
+ ;;
+ ;; multipart mixed [RFC1521,NSB]
+ ;; alternative [RFC1521,NSB]
+ ;; digest [RFC1521,NSB]
+ ;; parallel [RFC1521,NSB]
+ ;; appledouble [MacMime,Patrik Faltstrom]
+ ;; header-set [Dave Crocker]
+ ;;
+ ;; message rfc822 [RFC1521,NSB]
+ ;; partial [RFC1521,NSB]
+ ;; external-body [RFC1521,NSB]
+ ;; news [RFC 1036, Henry Spencer]
+ ;;
+ ;; application octet-stream [RFC1521,NSB]
+ ;; postscript [RFC1521,NSB]
+ ;; oda [RFC1521,NSB]
+ ;; atomicmail [atomicmail,NSB]
+ ;; andrew-inset [andrew-inset,NSB]
+ ;; slate [slate,terry crowley]
+ ;; wita [Wang Info Transfer,Larry Campbell]
+ ;; dec-dx [Digital Doc Trans, Larry Campbell]
+ ;; dca-rft [IBM Doc Content Arch, Larry Campbell]
+ ;; activemessage [Ehud Shapiro]
+ ;; rtf [Paul Lindner]
+ ;; applefile [MacMime,Patrik Faltstrom]
+ ;; mac-binhex40 [MacMime,Patrik Faltstrom]
+ ;; news-message-id [RFC1036, Henry Spencer]
+ ;; news-transmission [RFC1036, Henry Spencer]
+ ;; wordperfect5.1 [Paul Lindner]
+ ;; pdf [Paul Lindner]
+ ;; zip [Paul Lindner]
+ ;; macwriteii [Paul Lindner]
+ ;; msword [Paul Lindner]
+ ;; remote-printing [RFC1486,MTR]
+ ;;
+ ;; image jpeg [RFC1521,NSB]
+ ;; gif [RFC1521,NSB]
+ ;; ief Image Exchange Format [RFC1314]
+ ;; tiff Tag Image File Format [MTR]
+ ;;
+ ;; audio basic [RFC1521,NSB]
+ ;;
+ ;; video mpeg [RFC1521,NSB]
+ ;; quicktime [Paul Lindner]
+
+ ;; x-token :=
+ (define x-token
+ (lambda (value)
+ (let* ([r #rx"^[xX]-(.*)"]
+ [h (trim-spaces value)]
+ [ans (regexp-match r h)])
+ (and ans
+ (token (regexp-replace r h "\\1"))
+ h))))
+
+ ;; subtype := extension-token / iana-token
+ (define subtype
+ (lambda (value)
+ (if (not value)
+ (raise (make-empty-subtype))
+ (or (extension-token value)
+ (iana-token value)))))
+
+ ;; iana-token :=
+ (define iana-token
+ (lambda (value)
+ (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
+ (and ans (cdr ans)))))
+
+ ;; parameter := attribute "=" value
+ (define re:parameter (regexp "([^=]+)=(.+)"))
+ (define parameter
+ (lambda (par)
+ (let* ([r re:parameter]
+ [att (attribute (regexp-replace r par "\\1"))]
+ [val (value (regexp-replace r par "\\2"))])
+ (if (regexp-match r par)
+ (cons (if att (lowercase att) "???") val)
+ (cons "???" par)))))
+
+ ;; value := token / quoted-string
+ (define value
+ (lambda (val)
+ (or (token val)
+ (quoted-string val)
+ val)))
+
+ ;; token := 1*
+ ;; tspecials := "(" / ")" / "<" / ">" / "@" /
+ ;; "," / ";" / ":" / "\" / <">
+ ;; "/" / "[" / "]" / "?" / "="
+ ;; ; Must be in quoted-string,
+ ;; ; to use within parameter values
+ (define token
+ (lambda (value)
+ (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
+ [ans (regexp-match tspecials value)])
+ (and ans
+ (string=? value (car ans))
+ (car ans)))))
+
+ ;; attribute := token
+ ;; ; Matching of attributes
+ ;; ; is ALWAYS case-insensitive.
+ (define attribute token)
+
+ (define re:quotes (regexp "\"(.+)\""))
+ (define quoted-string
+ (lambda (str)
+ (let* ([quotes re:quotes]
+ [ans (regexp-match quotes str)])
+ (and ans (regexp-replace quotes str "\\1")))))
+
+ ;; disposition-parm := filename-parm
+ ;; / creation-date-parm
+ ;; / modification-date-parm
+ ;; / read-date-parm
+ ;; / size-parm
+ ;; / parameter
+ ;;
+ ;; filename-parm := "filename" "=" value
+ ;;
+ ;; creation-date-parm := "creation-date" "=" quoted-date-time
+ ;;
+ ;; modification-date-parm := "modification-date" "=" quoted-date-time
+ ;;
+ ;; read-date-parm := "read-date" "=" quoted-date-time
+ ;;
+ ;; size-parm := "size" "=" 1*DIGIT
+ (define disp-params
+ (lambda (lst disp)
+ (let loop ([lst lst])
+ (unless (null? lst)
+ (let* ([p (parameter (trim-all-spaces (car lst)))]
+ [parm (car p)]
+ [value (cdr p)])
+ (cond [(string=? parm "filename")
+ (set-disposition-filename! disp value)]
+ [(string=? parm "creation-date")
+ (set-disposition-creation!
+ disp
+ (disp-quoted-data-time value))]
+ [(string=? parm "modification-date")
+ (set-disposition-modification!
+ disp
+ (disp-quoted-data-time value))]
+ [(string=? parm "read-date")
+ (set-disposition-read!
+ disp
+ (disp-quoted-data-time value))]
+ [(string=? parm "size")
+ (set-disposition-size!
+ disp
+ (string->number value))]
+ [else
+ (set-disposition-params!
+ disp
+ (append (disposition-params disp) (list p)))])
+ (loop (cdr lst)))))))
+
+ ;; date-time = [ day "," ] date time ; dd mm yy
+ ;; ; hh:mm:ss zzz
+ ;;
+ ;; day = "Mon" / "Tue" / "Wed" / "Thu"
+ ;; / "Fri" / "Sat" / "Sun"
+ ;;
+ ;; date = 1*2DIGIT month 2DIGIT ; day month year
+ ;; ; e.g. 20 Jun 82
+ ;;
+ ;; month = "Jan" / "Feb" / "Mar" / "Apr"
+ ;; / "May" / "Jun" / "Jul" / "Aug"
+ ;; / "Sep" / "Oct" / "Nov" / "Dec"
+ ;;
+ ;; time = hour zone ; ANSI and Military
+ ;;
+ ;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT]
+ ;; ; 00:00:00 - 23:59:59
+ ;;
+ ;; zone = "UT" / "GMT" ; Universal Time
+ ;; ; North American : UT
+ ;; / "EST" / "EDT" ; Eastern: - 5/ - 4
+ ;; / "CST" / "CDT" ; Central: - 6/ - 5
+ ;; / "MST" / "MDT" ; Mountain: - 7/ - 6
+ ;; / "PST" / "PDT" ; Pacific: - 8/ - 7
+ ;; / 1ALPHA ; Military: Z = UT;
+ ;; ; A:-1; (J not used)
+ ;; ; M:-12; N:+1; Y:+12
+ ;; / ( ("+" / "-") 4DIGIT ) ; Local differential
+ ;; ; hours+min. (HHMM)
+ (define date-time
+ (lambda (str)
+ ;; Fix Me: I have to return a date structure, or time in seconds.
+ str))
+
+ ;; quoted-date-time := quoted-string
+ ;; ; contents MUST be an RFC 822 `date-time'
+ ;; ; numeric timezones (+HHMM or -HHMM) MUST be used
+
+ (define disp-quoted-data-time date-time)
+
+ )
diff --git a/collects/net/nntp-sig.ss b/collects/net/nntp-sig.ss
index d08d200..f6820ec 100644
--- a/collects/net/nntp-sig.ss
+++ b/collects/net/nntp-sig.ss
@@ -5,7 +5,7 @@
head-of-message body-of-message
newnews-since generic-message-command
make-desired-header extract-desired-headers
-
+
(struct nntp ())
(struct unexpected-response (code text))
(struct bad-status-line (line))
@@ -16,5 +16,3 @@
(struct no-group-selected ())
(struct article-not-found (article))
(struct authentication-rejected ()))
-
-
diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss
index ae306d1..8e7e0f9 100644
--- a/collects/net/nntp-unit.ss
+++ b/collects/net/nntp-unit.ss
@@ -1,337 +1,331 @@
(module nntp-unit (lib "a-unit.ss")
- (require (lib "etc.ss")
- "nntp-sig.ss")
+ (require (lib "etc.ss") "nntp-sig.ss")
(import)
(export nntp^)
- ;; sender : oport
- ;; receiver : iport
- ;; server : string
- ;; port : number
+ ;; sender : oport
+ ;; receiver : iport
+ ;; server : string
+ ;; port : number
- (define-struct communicator (sender receiver server port))
+ (define-struct communicator (sender receiver server port))
- ;; code : number
- ;; text : string
- ;; line : string
- ;; communicator : communicator
- ;; group : string
- ;; article : number
+ ;; code : number
+ ;; text : string
+ ;; line : string
+ ;; communicator : communicator
+ ;; group : string
+ ;; article : number
- (define-struct (nntp exn) ())
- (define-struct (unexpected-response nntp) (code text))
- (define-struct (bad-status-line nntp) (line))
- (define-struct (premature-close nntp) (communicator))
- (define-struct (bad-newsgroup-line nntp) (line))
- (define-struct (non-existent-group nntp) (group))
- (define-struct (article-not-in-group nntp) (article))
- (define-struct (no-group-selected nntp) ())
- (define-struct (article-not-found nntp) (article))
- (define-struct (authentication-rejected nntp) ())
+ (define-struct (nntp exn) ())
+ (define-struct (unexpected-response nntp) (code text))
+ (define-struct (bad-status-line nntp) (line))
+ (define-struct (premature-close nntp) (communicator))
+ (define-struct (bad-newsgroup-line nntp) (line))
+ (define-struct (non-existent-group nntp) (group))
+ (define-struct (article-not-in-group nntp) (article))
+ (define-struct (no-group-selected nntp) ())
+ (define-struct (article-not-found nntp) (article))
+ (define-struct (authentication-rejected nntp) ())
- ;; signal-error :
- ;; (exn-args ... -> exn) x format-string x values ... ->
- ;; exn-args -> ()
+ ;; signal-error :
+ ;; (exn-args ... -> exn) x format-string x values ... ->
+ ;; exn-args -> ()
- ;; - throws an exception
+ ;; - throws an exception
- (define signal-error
- (lambda (constructor format-string . args)
- (lambda exn-args
- (raise (apply constructor
- (string->immutable-string (apply format format-string args))
- (current-continuation-marks)
- exn-args)))))
+ (define signal-error
+ (lambda (constructor format-string . args)
+ (lambda exn-args
+ (raise (apply constructor
+ (string->immutable-string (apply format format-string args))
+ (current-continuation-marks)
+ exn-args)))))
- ;; default-nntpd-port-number :
- ;; number
+ ;; default-nntpd-port-number :
+ ;; number
- (define default-nntpd-port-number 119)
+ (define default-nntpd-port-number 119)
- ;; connect-to-server*:
- ;; input-port output-port -> communicator
-
- (define connect-to-server*
- (case-lambda
- [(receiver sender) (connect-to-server* receiver sender "unspecified"
- "unspecified")]
- [(receiver sender server-name port-number)
- (file-stream-buffer-mode sender 'line)
- (let ((communicator (make-communicator sender receiver server-name
- port-number)))
- (let-values (((code response)
- (get-single-line-response communicator)))
- (case code
- [(201) communicator]
- ((200)
- communicator)
- (else
- ((signal-error make-unexpected-response
- "unexpected connection response: ~s ~s"
- code response)
- code response)))))]))
-
- ;; connect-to-server :
- ;; string [x number] -> commnicator
+ ;; connect-to-server*:
+ ;; input-port output-port -> communicator
- (define connect-to-server
- (opt-lambda (server-name (port-number default-nntpd-port-number))
- (let-values (((receiver sender)
- (tcp-connect server-name port-number)))
- (connect-to-server* receiver sender server-name port-number))))
+ (define connect-to-server*
+ (case-lambda
+ [(receiver sender)
+ (connect-to-server* receiver sender "unspecified" "unspecified")]
+ [(receiver sender server-name port-number)
+ (file-stream-buffer-mode sender 'line)
+ (let ([communicator (make-communicator sender receiver server-name
+ port-number)])
+ (let-values ([(code response)
+ (get-single-line-response communicator)])
+ (case code
+ [(200 201) communicator]
+ [else ((signal-error make-unexpected-response
+ "unexpected connection response: ~s ~s"
+ code response)
+ code response)])))]))
- ;; close-communicator :
- ;; communicator -> ()
+ ;; connect-to-server :
+ ;; string [x number] -> commnicator
- (define close-communicator
- (lambda (communicator)
- (close-input-port (communicator-receiver communicator))
- (close-output-port (communicator-sender communicator))))
+ (define connect-to-server
+ (opt-lambda (server-name (port-number default-nntpd-port-number))
+ (let-values ([(receiver sender)
+ (tcp-connect server-name port-number)])
+ (connect-to-server* receiver sender server-name port-number))))
- ;; disconnect-from-server :
- ;; communicator -> ()
+ ;; close-communicator :
+ ;; communicator -> ()
- (define disconnect-from-server
- (lambda (communicator)
- (send-to-server communicator "QUIT")
- (let-values (((code response)
- (get-single-line-response communicator)))
- (case code
- ((205)
- (close-communicator communicator))
- (else
- ((signal-error make-unexpected-response
- "unexpected dis-connect response: ~s ~s"
- code response)
- code response))))))
+ (define close-communicator
+ (lambda (communicator)
+ (close-input-port (communicator-receiver communicator))
+ (close-output-port (communicator-sender communicator))))
- ;; authenticate-user :
- ;; communicator x user-name x password -> ()
- ;; the password is not used if the server does not ask for it.
+ ;; disconnect-from-server :
+ ;; communicator -> ()
- (define authenticate-user
- (lambda (communicator user password)
- (define (reject code response)
- ((signal-error make-authentication-rejected
- "authentication rejected (~s ~s)"
- code response)))
- (define (unexpected code response)
- ((signal-error make-unexpected-response
- "unexpected response for authentication: ~s ~s"
- code response)
- code response))
- (send-to-server communicator "AUTHINFO USER ~a" user)
- (let-values (((code response)
- (get-single-line-response communicator)))
+ (define disconnect-from-server
+ (lambda (communicator)
+ (send-to-server communicator "QUIT")
+ (let-values ([(code response)
+ (get-single-line-response communicator)])
+ (case code
+ [(205)
+ (close-communicator communicator)]
+ [else
+ ((signal-error make-unexpected-response
+ "unexpected dis-connect response: ~s ~s"
+ code response)
+ code response)]))))
+
+ ;; authenticate-user :
+ ;; communicator x user-name x password -> ()
+ ;; the password is not used if the server does not ask for it.
+
+ (define authenticate-user
+ (lambda (communicator user password)
+ (define (reject code response)
+ ((signal-error make-authentication-rejected
+ "authentication rejected (~s ~s)"
+ code response)))
+ (define (unexpected code response)
+ ((signal-error make-unexpected-response
+ "unexpected response for authentication: ~s ~s"
+ code response)
+ code response))
+ (send-to-server communicator "AUTHINFO USER ~a" user)
+ (let-values ([(code response) (get-single-line-response communicator)])
+ (case code
+ [(281) (void)] ; server doesn't ask for a password
+ [(381)
+ (send-to-server communicator "AUTHINFO PASS ~a" password)
+ (let-values ([(code response)
+ (get-single-line-response communicator)])
+ (case code
+ [(281) (void)] ; done
+ [(502) (reject code response)]
+ [else (unexpected code response)]))]
+ [(502) (reject code response)]
+ [else (reject code response)
+ (unexpected code response)]))))
+
+ ;; send-to-server :
+ ;; communicator x format-string x list (values) -> ()
+
+ (define send-to-server
+ (lambda (communicator message-template . rest)
+ (let ([sender (communicator-sender communicator)])
+ (apply fprintf sender
+ (string-append message-template "\r\n")
+ rest)
+ (flush-output sender))))
+
+ ;; parse-status-line :
+ ;; string -> number x string
+
+ (define parse-status-line
+ (lambda (line)
+ (if (eof-object? line)
+ ((signal-error make-bad-status-line "eof instead of a status line")
+ line)
+ (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
+ ((signal-error make-bad-status-line
+ "malformed status line: ~s" line)
+ line)))])
+ (values (string->number (car match))
+ (cadr match))))))
+
+ ;; get-one-line-from-server :
+ ;; iport -> string
+
+ (define get-one-line-from-server
+ (lambda (server->client-port)
+ (read-line server->client-port 'return-linefeed)))
+
+ ;; get-single-line-response :
+ ;; communicator -> number x string
+
+ (define get-single-line-response
+ (lambda (communicator)
+ (let ([receiver (communicator-receiver communicator)])
+ (let ([status-line (get-one-line-from-server receiver)])
+ (parse-status-line status-line)))))
+
+ ;; get-rest-of-multi-line-response :
+ ;; communicator -> list (string)
+
+ (define get-rest-of-multi-line-response
+ (lambda (communicator)
+ (let ([receiver (communicator-receiver communicator)])
+ (let loop ()
+ (let ([l (get-one-line-from-server receiver)])
+ (cond
+ [(eof-object? l)
+ ((signal-error make-premature-close
+ "port prematurely closed during multi-line response")
+ communicator)]
+ [(string=? l ".")
+ '()]
+ [(string=? l "..")
+ (cons "." (loop))]
+ [else
+ (cons l (loop))]))))))
+
+ ;; get-multi-line-response :
+ ;; communicator -> number x string x list (string)
+
+ ;; -- The returned values are the status code, the rest of the status
+ ;; response line, and the remaining lines.
+
+ (define get-multi-line-response
+ (lambda (communicator)
+ (let* ([receiver (communicator-receiver communicator)]
+ [status-line (get-one-line-from-server receiver)])
+ (let-values ([(code rest-of-line)
+ (parse-status-line status-line)])
+ (values code rest-of-line (get-rest-of-multi-line-response))))))
+
+ ;; open-news-group :
+ ;; communicator x string -> number x number x number
+
+ ;; -- The returned values are the number of articles, the first
+ ;; article number, and the last article number for that group.
+
+ (define open-news-group
+ (lambda (communicator group-name)
+ (send-to-server communicator "GROUP ~a" group-name)
+ (let-values ([(code rest-of-line)
+ (get-single-line-response communicator)])
+ (case code
+ [(211)
+ (let ([match (map string->number
+ (cdr
+ (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
+ ((signal-error make-bad-newsgroup-line
+ "malformed newsgroup open response: ~s"
+ rest-of-line)
+ rest-of-line))))])
+ (let ([number-of-articles (car match)]
+ [first-article-number (cadr match)]
+ [last-article-number (caddr match)])
+ (values number-of-articles
+ first-article-number
+ last-article-number)))]
+ [(411)
+ ((signal-error make-non-existent-group
+ "group ~s does not exist on server ~s"
+ group-name (communicator-server communicator))
+ group-name)]
+ [else
+ ((signal-error make-unexpected-response
+ "unexpected group opening response: ~s" code)
+ code rest-of-line)]))))
+
+ ;; generic-message-command :
+ ;; string x number -> communicator x (number U string) -> list (string)
+
+ (define generic-message-command
+ (lambda (command ok-code)
+ (lambda (communicator message-index)
+ (send-to-server communicator (string-append command " ~a")
+ (if (number? message-index)
+ (number->string message-index)
+ message-index))
+ (let-values ([(code response)
+ (get-single-line-response communicator)])
+ (if (= code ok-code)
+ (get-rest-of-multi-line-response communicator)
(case code
- ((281) (void)) ; server doesn't ask for a password
- ((381)
- (send-to-server communicator "AUTHINFO PASS ~a" password)
- (let-values (((code response)
- (get-single-line-response communicator)))
- (case code
- ((281) (void)) ; done
- ((502) (reject code response))
- (else (unexpected code response)))))
- ((502) (reject code response))
- (else (reject code response)
- (unexpected code response))))))
-
- ;; send-to-server :
- ;; communicator x format-string x list (values) -> ()
-
- (define send-to-server
- (lambda (communicator message-template . rest)
- (let ([sender (communicator-sender communicator)])
- (apply fprintf sender
- (string-append message-template "\r\n")
- rest)
- (flush-output sender))))
-
- ;; parse-status-line :
- ;; string -> number x string
-
- (define parse-status-line
- (lambda (line)
- (if (eof-object? line)
- ((signal-error make-bad-status-line "eof instead of a status line")
- line)
- (let ((match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
- ((signal-error make-bad-status-line
- "malformed status line: ~s" line)
- line)))))
- (values (string->number (car match))
- (cadr match))))))
-
- ;; get-one-line-from-server :
- ;; iport -> string
-
- (define get-one-line-from-server
- (lambda (server->client-port)
- (read-line server->client-port 'return-linefeed)))
-
- ;; get-single-line-response :
- ;; communicator -> number x string
-
- (define get-single-line-response
- (lambda (communicator)
- (let ((receiver (communicator-receiver communicator)))
- (let ((status-line (get-one-line-from-server receiver)))
- (parse-status-line status-line)))))
-
- ;; get-rest-of-multi-line-response :
- ;; communicator -> list (string)
-
- (define get-rest-of-multi-line-response
- (lambda (communicator)
- (let ((receiver (communicator-receiver communicator)))
- (let loop ()
- (let ((l (get-one-line-from-server receiver)))
- (cond
- ((eof-object? l)
- ((signal-error make-premature-close
- "port prematurely closed during multi-line response")
- communicator))
- ((string=? l ".")
- '())
- ((string=? l "..")
- (cons "." (loop)))
- (else
- (cons l (loop)))))))))
-
- ;; get-multi-line-response :
- ;; communicator -> number x string x list (string)
-
- ;; -- The returned values are the status code, the rest of the status
- ;; response line, and the remaining lines.
-
- (define get-multi-line-response
- (lambda (communicator)
- (let ((receiver (communicator-receiver communicator)))
- (let ((status-line (get-one-line-from-server receiver)))
- (let-values (((code rest-of-line)
- (parse-status-line status-line)))
- (values code rest-of-line (get-rest-of-multi-line-response)))))))
-
- ;; open-news-group :
- ;; communicator x string -> number x number x number
-
- ;; -- The returned values are the number of articles, the first
- ;; article number, and the last article number for that group.
-
- (define open-news-group
- (lambda (communicator group-name)
- (send-to-server communicator "GROUP ~a" group-name)
- (let-values (((code rest-of-line)
- (get-single-line-response communicator)))
- (case code
- ((211)
- (let ((match (map string->number
- (cdr
- (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
- ((signal-error make-bad-newsgroup-line
- "malformed newsgroup open response: ~s"
- rest-of-line)
- rest-of-line))))))
- (let ((number-of-articles (car match))
- (first-article-number (cadr match))
- (last-article-number (caddr match)))
- (values number-of-articles
- first-article-number
- last-article-number))))
- ((411)
- ((signal-error make-non-existent-group
- "group ~s does not exist on server ~s"
- group-name (communicator-server communicator))
- group-name))
- (else
+ [(423)
+ ((signal-error make-article-not-in-group
+ "article id ~s not in group" message-index)
+ message-index)]
+ [(412)
+ ((signal-error make-no-group-selected
+ "no group selected"))]
+ [(430)
+ ((signal-error make-article-not-found
+ "no article id ~s found" message-index)
+ message-index)]
+ [else
((signal-error make-unexpected-response
- "unexpected group opening response: ~s" code)
- code rest-of-line))))))
+ "unexpected message access response: ~s" code)
+ code response)]))))))
- ;; generic-message-command :
- ;; string x number -> communicator x (number U string) -> list (string)
+ ;; head-of-message :
+ ;; communicator x (number U string) -> list (string)
- (define generic-message-command
- (lambda (command ok-code)
- (lambda (communicator message-index)
- (send-to-server communicator (string-append command " ~a")
- (if (number? message-index)
- (number->string message-index)
- message-index))
- (let-values (((code response)
- (get-single-line-response communicator)))
- (if (= code ok-code)
- (get-rest-of-multi-line-response communicator)
- (case code
- ((423)
- ((signal-error make-article-not-in-group
- "article id ~s not in group" message-index)
- message-index))
- ((412)
- ((signal-error make-no-group-selected
- "no group selected")))
- ((430)
- ((signal-error make-article-not-found
- "no article id ~s found" message-index)
- message-index))
- (else
- ((signal-error make-unexpected-response
- "unexpected message access response: ~s" code)
- code response))))))))
+ (define head-of-message
+ (generic-message-command "HEAD" 221))
- ;; head-of-message :
- ;; communicator x (number U string) -> list (string)
+ ;; body-of-message :
+ ;; communicator x (number U string) -> list (string)
- (define head-of-message
- (generic-message-command "HEAD" 221))
+ (define body-of-message
+ (generic-message-command "BODY" 222))
- ;; body-of-message :
- ;; communicator x (number U string) -> list (string)
+ ;; newnews-since :
+ ;; communicator x (number U string) -> list (string)
- (define body-of-message
- (generic-message-command "BODY" 222))
+ (define newnews-since
+ (generic-message-command "NEWNEWS" 230))
- ;; newnews-since :
- ;; communicator x (number U string) -> list (string)
-
- (define newnews-since
- (generic-message-command "NEWNEWS" 230))
+ ;; make-desired-header :
+ ;; string -> desired
- ;; make-desired-header :
- ;; string -> desired
+ (define make-desired-header
+ (lambda (raw-header)
+ (regexp
+ (string-append
+ "^"
+ (list->string
+ (apply append
+ (map (lambda (c)
+ (cond
+ [(char-lower-case? c)
+ (list #\[ (char-upcase c) c #\])]
+ [(char-upper-case? c)
+ (list #\[ c (char-downcase c) #\])]
+ [else
+ (list c)]))
+ (string->list raw-header))))
+ ":"))))
- (define make-desired-header
- (lambda (raw-header)
- (regexp
- (string-append
- "^"
- (list->string
- (apply append
- (map (lambda (c)
- (cond
- ((char-lower-case? c)
- (list #\[ (char-upcase c) c #\]))
- ((char-upper-case? c)
- (list #\[ c (char-downcase c) #\]))
- (else
- (list c))))
- (string->list raw-header))))
- ":"))))
-
- ;; extract-desired-headers :
- ;; list (string) x list (desired) -> list (string)
-
- (define extract-desired-headers
- (lambda (headers desireds)
- (let loop ((headers headers))
- (if (null? headers) null
- (let ((first (car headers))
- (rest (cdr headers)))
- (if (ormap (lambda (matcher)
- (regexp-match matcher first))
- desireds)
- (cons first (loop rest))
- (loop rest))))))))
+ ;; extract-desired-headers :
+ ;; list (string) x list (desired) -> list (string)
+ (define extract-desired-headers
+ (lambda (headers desireds)
+ (let loop ([headers headers])
+ (if (null? headers) null
+ (let ([first (car headers)]
+ [rest (cdr headers)])
+ (if (ormap (lambda (matcher)
+ (regexp-match matcher first))
+ desireds)
+ (cons first (loop rest))
+ (loop rest))))))))
diff --git a/collects/net/pop3-sig.ss b/collects/net/pop3-sig.ss
index 67cf18d..243fe06 100644
--- a/collects/net/pop3-sig.ss
+++ b/collects/net/pop3-sig.ss
@@ -6,9 +6,9 @@
get-message/complete get-message/headers get-message/body
delete-message
get-unique-id/single get-unique-id/all
-
+
make-desired-header extract-desired-headers
-
+
(struct pop3 ())
(struct cannot-connect ())
(struct username-rejected ())
diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss
index e9c2717..6f8a728 100644
--- a/collects/net/pop3-unit.ss
+++ b/collects/net/pop3-unit.ss
@@ -1,410 +1,405 @@
(module pop3-unit (lib "a-unit.ss")
- (require (lib "etc.ss")
- "pop3-sig.ss")
+ (require (lib "etc.ss") "pop3-sig.ss")
(import)
(export pop3^)
- ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
+ ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
- ;; sender : oport
- ;; receiver : iport
- ;; server : string
- ;; port : number
- ;; state : symbol = (disconnected, authorization, transaction)
+ ;; sender : oport
+ ;; receiver : iport
+ ;; server : string
+ ;; port : number
+ ;; state : symbol = (disconnected, authorization, transaction)
- (define-struct communicator (sender receiver server port state))
+ (define-struct communicator (sender receiver server port state))
- (define-struct (pop3 exn) ())
- (define-struct (cannot-connect pop3) ())
- (define-struct (username-rejected pop3) ())
- (define-struct (password-rejected pop3) ())
- (define-struct (not-ready-for-transaction pop3) (communicator))
- (define-struct (not-given-headers pop3) (communicator message))
- (define-struct (illegal-message-number pop3) (communicator message))
- (define-struct (cannot-delete-message exn) (communicator message))
- (define-struct (disconnect-not-quiet pop3) (communicator))
- (define-struct (malformed-server-response pop3) (communicator))
+ (define-struct (pop3 exn) ())
+ (define-struct (cannot-connect pop3) ())
+ (define-struct (username-rejected pop3) ())
+ (define-struct (password-rejected pop3) ())
+ (define-struct (not-ready-for-transaction pop3) (communicator))
+ (define-struct (not-given-headers pop3) (communicator message))
+ (define-struct (illegal-message-number pop3) (communicator message))
+ (define-struct (cannot-delete-message exn) (communicator message))
+ (define-struct (disconnect-not-quiet pop3) (communicator))
+ (define-struct (malformed-server-response pop3) (communicator))
- ;; signal-error :
- ;; (exn-args ... -> exn) x format-string x values ... ->
- ;; exn-args -> ()
+ ;; signal-error :
+ ;; (exn-args ... -> exn) x format-string x values ... ->
+ ;; exn-args -> ()
- (define signal-error
- (lambda (constructor format-string . args)
- (lambda exn-args
- (raise (apply constructor
- (string->immutable-string
- (apply format format-string args))
- (current-continuation-marks)
- exn-args)))))
+ (define signal-error
+ (lambda (constructor format-string . args)
+ (lambda exn-args
+ (raise (apply constructor
+ (string->immutable-string
+ (apply format format-string args))
+ (current-continuation-marks)
+ exn-args)))))
- ;; signal-malformed-response-error :
- ;; exn-args -> ()
+ ;; signal-malformed-response-error :
+ ;; exn-args -> ()
- ;; -- in practice, it takes only one argument: a communicator.
+ ;; -- in practice, it takes only one argument: a communicator.
- (define signal-malformed-response-error
- (signal-error make-malformed-server-response
- "malformed response from server"))
+ (define signal-malformed-response-error
+ (signal-error make-malformed-server-response
+ "malformed response from server"))
- ;; confirm-transaction-mode :
- ;; communicator x string -> ()
+ ;; confirm-transaction-mode :
+ ;; communicator x string -> ()
- ;; -- signals an error otherwise.
+ ;; -- signals an error otherwise.
- (define confirm-transaction-mode
- (lambda (communicator error-message)
- (unless (eq? (communicator-state communicator) 'transaction)
- ((signal-error make-not-ready-for-transaction error-message)
- communicator))))
+ (define confirm-transaction-mode
+ (lambda (communicator error-message)
+ (unless (eq? (communicator-state communicator) 'transaction)
+ ((signal-error make-not-ready-for-transaction error-message)
+ communicator))))
- ;; default-pop-port-number :
- ;; number
+ ;; default-pop-port-number :
+ ;; number
- (define default-pop-port-number 110)
+ (define default-pop-port-number 110)
- (define-struct server-responses ())
- (define-struct (+ok server-responses) ())
- (define-struct (-err server-responses) ())
+ (define-struct server-responses ())
+ (define-struct (+ok server-responses) ())
+ (define-struct (-err server-responses) ())
- ;; connect-to-server*:
- ;; input-port output-port -> communicator
+ ;; connect-to-server*:
+ ;; input-port output-port -> communicator
- (define connect-to-server*
- (case-lambda
- [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")]
- [(receiver sender server-name port-number)
- (let ((communicator (make-communicator sender receiver server-name port-number
- 'authorization)))
- (let ((response (get-status-response/basic communicator)))
- (cond
- ((+ok? response) communicator)
- ((-err? response)
- ((signal-error make-cannot-connect
- "cannot connect to ~a on port ~a"
- server-name port-number))))))]))
-
- ;; connect-to-server :
- ;; string [x number] -> communicator
+ (define connect-to-server*
+ (case-lambda
+ [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")]
+ [(receiver sender server-name port-number)
+ (let ([communicator (make-communicator sender receiver server-name port-number
+ 'authorization)])
+ (let ([response (get-status-response/basic communicator)])
+ (cond
+ [(+ok? response) communicator]
+ [(-err? response)
+ ((signal-error make-cannot-connect
+ "cannot connect to ~a on port ~a"
+ server-name port-number))])))]))
- (define connect-to-server
- (opt-lambda (server-name (port-number default-pop-port-number))
- (let-values (((receiver sender) (tcp-connect server-name port-number)))
- (connect-to-server* receiver sender server-name port-number))))
+ ;; connect-to-server :
+ ;; string [x number] -> communicator
- ;; authenticate/plain-text :
- ;; string x string x communicator -> ()
+ (define connect-to-server
+ (opt-lambda (server-name (port-number default-pop-port-number))
+ (let-values ([(receiver sender) (tcp-connect server-name port-number)])
+ (connect-to-server* receiver sender server-name port-number))))
- ;; -- if authentication succeeds, sets the communicator's state to
- ;; transaction.
+ ;; authenticate/plain-text :
+ ;; string x string x communicator -> ()
- (define authenticate/plain-text
- (lambda (username password communicator)
- (let ((sender (communicator-sender communicator)))
- (send-to-server communicator "USER ~a" username)
- (let ((status (get-status-response/basic communicator)))
- (cond
- ((+ok? status)
- (send-to-server communicator "PASS ~a" password)
- (let ((status (get-status-response/basic communicator)))
- (cond
- ((+ok? status)
- (set-communicator-state! communicator 'transaction))
- ((-err? status)
- ((signal-error make-password-rejected
- "password was rejected"))))))
- ((-err? status)
- ((signal-error make-username-rejected
- "username was rejected"))))))))
+ ;; -- if authentication succeeds, sets the communicator's state to
+ ;; transaction.
- ;; get-mailbox-status :
- ;; communicator -> number x number
+ (define authenticate/plain-text
+ (lambda (username password communicator)
+ (let ([sender (communicator-sender communicator)])
+ (send-to-server communicator "USER ~a" username)
+ (let ([status (get-status-response/basic communicator)])
+ (cond
+ [(+ok? status)
+ (send-to-server communicator "PASS ~a" password)
+ (let ([status (get-status-response/basic communicator)])
+ (cond
+ [(+ok? status)
+ (set-communicator-state! communicator 'transaction)]
+ [(-err? status)
+ ((signal-error make-password-rejected
+ "password was rejected"))]))]
+ [(-err? status)
+ ((signal-error make-username-rejected
+ "username was rejected"))])))))
- ;; -- returns number of messages and number of octets.
+ ;; get-mailbox-status :
+ ;; communicator -> number x number
- (define get-mailbox-status
- (lambda (communicator)
- (confirm-transaction-mode
- communicator
- "cannot get mailbox status unless in transaction mode")
- (send-to-server communicator "STAT")
- (apply values
- (map string->number
- (let-values (((status result)
- (get-status-response/match
- communicator
- #rx"([0-9]+) ([0-9]+)"
- #f)))
- result)))))
+ ;; -- returns number of messages and number of octets.
- ;; get-message/complete :
- ;; communicator x number -> list (string) x list (string)
+ (define get-mailbox-status
+ (lambda (communicator)
+ (confirm-transaction-mode
+ communicator
+ "cannot get mailbox status unless in transaction mode")
+ (send-to-server communicator "STAT")
+ (apply values
+ (map string->number
+ (let-values ([(status result)
+ (get-status-response/match
+ communicator
+ #rx"([0-9]+) ([0-9]+)"
+ #f)])
+ result)))))
- (define get-message/complete
- (lambda (communicator message)
- (confirm-transaction-mode communicator
- "cannot get message headers unless in transaction state")
- (send-to-server communicator "RETR ~a" message)
- (let ((status (get-status-response/basic communicator)))
- (cond
- ((+ok? status)
- (split-header/body (get-multi-line-response communicator)))
- ((-err? status)
- ((signal-error make-illegal-message-number
- "not given message ~a" message)
- communicator message))))))
+ ;; get-message/complete :
+ ;; communicator x number -> list (string) x list (string)
- ;; get-message/headers :
- ;; communicator x number -> list (string)
+ (define get-message/complete
+ (lambda (communicator message)
+ (confirm-transaction-mode communicator
+ "cannot get message headers unless in transaction state")
+ (send-to-server communicator "RETR ~a" message)
+ (let ([status (get-status-response/basic communicator)])
+ (cond
+ [(+ok? status)
+ (split-header/body (get-multi-line-response communicator))]
+ [(-err? status)
+ ((signal-error make-illegal-message-number
+ "not given message ~a" message)
+ communicator message)]))))
- (define get-message/headers
- (lambda (communicator message)
- (confirm-transaction-mode communicator
- "cannot get message headers unless in transaction state")
- (send-to-server communicator "TOP ~a 0" message)
- (let ((status (get-status-response/basic communicator)))
- (cond
- ((+ok? status)
- (let-values (((headers body)
- (split-header/body
- (get-multi-line-response communicator))))
- headers))
- ((-err? status)
- ((signal-error make-not-given-headers
- "not given headers to message ~a" message)
- communicator message))))))
+ ;; get-message/headers :
+ ;; communicator x number -> list (string)
- ;; get-message/body :
- ;; communicator x number -> list (string)
+ (define get-message/headers
+ (lambda (communicator message)
+ (confirm-transaction-mode communicator
+ "cannot get message headers unless in transaction state")
+ (send-to-server communicator "TOP ~a 0" message)
+ (let ([status (get-status-response/basic communicator)])
+ (cond
+ [(+ok? status)
+ (let-values ([(headers body)
+ (split-header/body
+ (get-multi-line-response communicator))])
+ headers)]
+ [(-err? status)
+ ((signal-error make-not-given-headers
+ "not given headers to message ~a" message)
+ communicator message)]))))
- (define get-message/body
- (lambda (communicator message)
- (let-values (((headers body)
- (get-message/complete communicator message)))
- body)))
+ ;; get-message/body :
+ ;; communicator x number -> list (string)
- ;; split-header/body :
- ;; list (string) -> list (string) x list (string)
+ (define get-message/body
+ (lambda (communicator message)
+ (let-values ([(headers body) (get-message/complete communicator message)])
+ body)))
- ;; -- returns list of headers and list of body lines.
+ ;; split-header/body :
+ ;; list (string) -> list (string) x list (string)
- (define split-header/body
- (lambda (lines)
- (let loop ((lines lines) (header null))
- (if (null? lines)
- (values (reverse header) null)
- (let ((first (car lines))
- (rest (cdr lines)))
- (if (string=? first "")
- (values (reverse header) rest)
- (loop rest (cons first header))))))))
+ ;; -- returns list of headers and list of body lines.
- ;; delete-message :
- ;; communicator x number -> ()
+ (define split-header/body
+ (lambda (lines)
+ (let loop ([lines lines] [header null])
+ (if (null? lines)
+ (values (reverse header) null)
+ (let ([first (car lines)]
+ [rest (cdr lines)])
+ (if (string=? first "")
+ (values (reverse header) rest)
+ (loop rest (cons first header))))))))
- (define delete-message
- (lambda (communicator message)
- (confirm-transaction-mode communicator
- "cannot delete message unless in transaction state")
- (send-to-server communicator "DELE ~a" message)
- (let ((status (get-status-response/basic communicator)))
- (cond
- ((-err? status)
- ((signal-error make-cannot-delete-message
- "no message numbered ~a available to be deleted" message)
- communicator message))
- ((+ok? status)
- 'deleted)))))
+ ;; delete-message :
+ ;; communicator x number -> ()
- ;; regexp for UIDL responses
+ (define delete-message
+ (lambda (communicator message)
+ (confirm-transaction-mode communicator
+ "cannot delete message unless in transaction state")
+ (send-to-server communicator "DELE ~a" message)
+ (let ([status (get-status-response/basic communicator)])
+ (cond
+ [(-err? status)
+ ((signal-error make-cannot-delete-message
+ "no message numbered ~a available to be deleted" message)
+ communicator message)]
+ [(+ok? status)
+ 'deleted]))))
- (define uidl-regexp #rx"([0-9]+) (.*)")
+ ;; regexp for UIDL responses
- ;; get-unique-id/single :
- ;; communicator x number -> string
+ (define uidl-regexp #rx"([0-9]+) (.*)")
- (define (get-unique-id/single communicator message)
- (confirm-transaction-mode communicator
- "cannot get unique message id unless in transaction state")
- (send-to-server communicator "UIDL ~a" message)
- (let-values (((status result)
- (get-status-response/match communicator
- uidl-regexp
- ".*")))
- ;; The server response is of the form
- ;; +OK 2 QhdPYR:00WBw1Ph7x7
- (cond
- ((-err? status)
- ((signal-error make-illegal-message-number
- "no message numbered ~a available for unique id" message)
- communicator message))
- ((+ok? status)
- (cadr result)))))
+ ;; get-unique-id/single :
+ ;; communicator x number -> string
- ;; get-unique-id/all :
- ;; communicator -> list(number x string)
+ (define (get-unique-id/single communicator message)
+ (confirm-transaction-mode communicator
+ "cannot get unique message id unless in transaction state")
+ (send-to-server communicator "UIDL ~a" message)
+ (let-values ([(status result)
+ (get-status-response/match communicator uidl-regexp ".*")])
+ ;; The server response is of the form
+ ;; +OK 2 QhdPYR:00WBw1Ph7x7
+ (cond
+ [(-err? status)
+ ((signal-error make-illegal-message-number
+ "no message numbered ~a available for unique id" message)
+ communicator message)]
+ [(+ok? status)
+ (cadr result)])))
- (define (get-unique-id/all communicator)
- (confirm-transaction-mode communicator
- "cannot get unique message ids unless in transaction state")
- (send-to-server communicator "UIDL")
- (let ((status (get-status-response/basic communicator)))
- ;; The server response is of the form
- ;; +OK
- ;; 1 whqtswO00WBw418f9t5JxYwZ
- ;; 2 QhdPYR:00WBw1Ph7x7
- ;; .
- (map (lambda (l)
- (let ((m (regexp-match uidl-regexp l)))
- (cons (string->number (cadr m)) (caddr m))))
- (get-multi-line-response communicator))))
+ ;; get-unique-id/all :
+ ;; communicator -> list(number x string)
- ;; close-communicator :
- ;; communicator -> ()
+ (define (get-unique-id/all communicator)
+ (confirm-transaction-mode communicator
+ "cannot get unique message ids unless in transaction state")
+ (send-to-server communicator "UIDL")
+ (let ([status (get-status-response/basic communicator)])
+ ;; The server response is of the form
+ ;; +OK
+ ;; 1 whqtswO00WBw418f9t5JxYwZ
+ ;; 2 QhdPYR:00WBw1Ph7x7
+ ;; .
+ (map (lambda (l)
+ (let ([m (regexp-match uidl-regexp l)])
+ (cons (string->number (cadr m)) (caddr m))))
+ (get-multi-line-response communicator))))
- (define close-communicator
- (lambda (communicator)
- (close-input-port (communicator-receiver communicator))
- (close-output-port (communicator-sender communicator))))
+ ;; close-communicator :
+ ;; communicator -> ()
- ;; disconnect-from-server :
- ;; communicator -> ()
+ (define close-communicator
+ (lambda (communicator)
+ (close-input-port (communicator-receiver communicator))
+ (close-output-port (communicator-sender communicator))))
- (define disconnect-from-server
- (lambda (communicator)
- (send-to-server communicator "QUIT")
- (set-communicator-state! communicator 'disconnected)
- (let ((response (get-status-response/basic communicator)))
- (close-communicator communicator)
- (cond
- ((+ok? response) (void))
- ((-err? response)
- ((signal-error make-disconnect-not-quiet
- "got error status upon disconnect")
- communicator))))))
+ ;; disconnect-from-server :
+ ;; communicator -> ()
- ;; send-to-server :
- ;; communicator x format-string x list (values) -> ()
+ (define disconnect-from-server
+ (lambda (communicator)
+ (send-to-server communicator "QUIT")
+ (set-communicator-state! communicator 'disconnected)
+ (let ([response (get-status-response/basic communicator)])
+ (close-communicator communicator)
+ (cond
+ [(+ok? response) (void)]
+ [(-err? response)
+ ((signal-error make-disconnect-not-quiet
+ "got error status upon disconnect")
+ communicator)]))))
- (define send-to-server
- (lambda (communicator message-template . rest)
- (apply fprintf (communicator-sender communicator)
- (string-append message-template "\r\n")
- rest)
- (flush-output (communicator-sender communicator))))
+ ;; send-to-server :
+ ;; communicator x format-string x list (values) -> ()
- ;; get-one-line-from-server :
- ;; iport -> string
+ (define send-to-server
+ (lambda (communicator message-template . rest)
+ (apply fprintf (communicator-sender communicator)
+ (string-append message-template "\r\n")
+ rest)
+ (flush-output (communicator-sender communicator))))
- (define get-one-line-from-server
- (lambda (server->client-port)
- (read-line server->client-port 'return-linefeed)))
+ ;; get-one-line-from-server :
+ ;; iport -> string
- ;; get-server-status-response :
- ;; communicator -> server-responses x string
+ (define get-one-line-from-server
+ (lambda (server->client-port)
+ (read-line server->client-port 'return-linefeed)))
- ;; -- provides the low-level functionality of checking for +OK
- ;; and -ERR, returning an appropriate structure, and returning the
- ;; rest of the status response as a string to be used for further
- ;; parsing, if necessary.
+ ;; get-server-status-response :
+ ;; communicator -> server-responses x string
- (define get-server-status-response
- (lambda (communicator)
- (let* ((receiver (communicator-receiver communicator))
- (status-line (get-one-line-from-server receiver))
- (r (regexp-match #rx"^\\+OK(.*)" status-line)))
+ ;; -- provides the low-level functionality of checking for +OK
+ ;; and -ERR, returning an appropriate structure, and returning the
+ ;; rest of the status response as a string to be used for further
+ ;; parsing, if necessary.
+
+ (define get-server-status-response
+ (lambda (communicator)
+ (let* ([receiver (communicator-receiver communicator)]
+ [status-line (get-one-line-from-server receiver)]
+ [r (regexp-match #rx"^\\+OK(.*)" status-line)])
+ (if r
+ (values (make-+ok) (cadr r))
+ (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
(if r
- (values (make-+ok) (cadr r))
- (let ((r (regexp-match #rx"^\\-ERR(.*)" status-line)))
- (if r
- (values (make--err) (cadr r))
- (signal-malformed-response-error communicator)))))))
+ (values (make--err) (cadr r))
+ (signal-malformed-response-error communicator)))))))
- ;; get-status-response/basic :
- ;; communicator -> server-responses
+ ;; get-status-response/basic :
+ ;; communicator -> server-responses
- ;; -- when the only thing to determine is whether the response
- ;; was +OK or -ERR.
+ ;; -- when the only thing to determine is whether the response
+ ;; was +OK or -ERR.
- (define get-status-response/basic
- (lambda (communicator)
- (let-values (((response rest)
- (get-server-status-response communicator)))
- response)))
+ (define get-status-response/basic
+ (lambda (communicator)
+ (let-values ([(response rest)
+ (get-server-status-response communicator)])
+ response)))
- ;; get-status-response/match :
- ;; communicator x regexp x regexp -> (status x list (string))
+ ;; get-status-response/match :
+ ;; communicator x regexp x regexp -> (status x list (string))
- ;; -- when further parsing of the status response is necessary.
- ;; Strips off the car of response from regexp-match.
+ ;; -- when further parsing of the status response is necessary.
+ ;; Strips off the car of response from regexp-match.
- (define get-status-response/match
- (lambda (communicator +regexp -regexp)
- (let-values (((response rest)
- (get-server-status-response communicator)))
- (if (and +regexp (+ok? response))
- (let ((r (regexp-match +regexp rest)))
- (if r (values response (cdr r))
- (signal-malformed-response-error communicator)))
- (if (and -regexp (-err? response))
- (let ((r (regexp-match -regexp rest)))
- (if r (values response (cdr r))
- (signal-malformed-response-error communicator)))
- (signal-malformed-response-error communicator))))))
+ (define get-status-response/match
+ (lambda (communicator +regexp -regexp)
+ (let-values ([(response rest)
+ (get-server-status-response communicator)])
+ (if (and +regexp (+ok? response))
+ (let ([r (regexp-match +regexp rest)])
+ (if r (values response (cdr r))
+ (signal-malformed-response-error communicator)))
+ (if (and -regexp (-err? response))
+ (let ([r (regexp-match -regexp rest)])
+ (if r (values response (cdr r))
+ (signal-malformed-response-error communicator)))
+ (signal-malformed-response-error communicator))))))
- ;; get-multi-line-response :
- ;; communicator -> list (string)
+ ;; get-multi-line-response :
+ ;; communicator -> list (string)
- (define get-multi-line-response
- (lambda (communicator)
- (let ((receiver (communicator-receiver communicator)))
- (let loop ()
- (let ((l (get-one-line-from-server receiver)))
- (cond
- ((eof-object? l)
- (signal-malformed-response-error communicator))
- ((string=? l ".")
- '())
- ((and (> (string-length l) 1)
- (char=? (string-ref l 0) #\.))
- (cons (substring l 1 (string-length l)) (loop)))
- (else
- (cons l (loop)))))))))
+ (define get-multi-line-response
+ (lambda (communicator)
+ (let ([receiver (communicator-receiver communicator)])
+ (let loop ()
+ (let ([l (get-one-line-from-server receiver)])
+ (cond
+ [(eof-object? l)
+ (signal-malformed-response-error communicator)]
+ [(string=? l ".")
+ '()]
+ [(and (> (string-length l) 1)
+ (char=? (string-ref l 0) #\.))
+ (cons (substring l 1 (string-length l)) (loop))]
+ [else
+ (cons l (loop))]))))))
- ;; make-desired-header :
- ;; string -> desired
+ ;; make-desired-header :
+ ;; string -> desired
- (define make-desired-header
- (lambda (raw-header)
- (regexp
- (string-append
- "^"
- (list->string
- (apply append
- (map (lambda (c)
- (cond
- ((char-lower-case? c)
- (list #\[ (char-upcase c) c #\]))
- ((char-upper-case? c)
- (list #\[ c (char-downcase c) #\]))
- (else
- (list c))))
- (string->list raw-header))))
- ":"))))
+ (define make-desired-header
+ (lambda (raw-header)
+ (regexp
+ (string-append
+ "^"
+ (list->string
+ (apply append
+ (map (lambda (c)
+ (cond
+ [(char-lower-case? c)
+ (list #\[ (char-upcase c) c #\])]
+ [(char-upper-case? c)
+ (list #\[ c (char-downcase c) #\])]
+ [else
+ (list c)]))
+ (string->list raw-header))))
+ ":"))))
- ;; extract-desired-headers :
- ;; list (string) x list (desired) -> list (string)
-
- (define extract-desired-headers
- (lambda (headers desireds)
- (let loop ((headers headers))
- (if (null? headers) null
- (let ((first (car headers))
- (rest (cdr headers)))
- (if (ormap (lambda (matcher)
- (regexp-match matcher first))
- desireds)
- (cons first (loop rest))
- (loop rest))))))))
+ ;; extract-desired-headers :
+ ;; list (string) x list (desired) -> list (string)
+ (define extract-desired-headers
+ (lambda (headers desireds)
+ (let loop ([headers headers])
+ (if (null? headers) null
+ (let ([first (car headers)]
+ [rest (cdr headers)])
+ (if (ormap (lambda (matcher)
+ (regexp-match matcher first))
+ desireds)
+ (cons first (loop rest))
+ (loop rest))))))))
diff --git a/collects/net/qp-sig.ss b/collects/net/qp-sig.ss
index 90b30ca..5e02607 100644
--- a/collects/net/qp-sig.ss
+++ b/collects/net/qp-sig.ss
@@ -3,7 +3,7 @@
(struct qp-error () -setters -constructor)
(struct qp-wrong-input () -setters -constructor)
(struct qp-wrong-line-size (size) -setters -constructor)
-
+
;; -- qp methods --
qp-encode
qp-decode
diff --git a/collects/net/qp-unit.ss b/collects/net/qp-unit.ss
index d9510be..e126d43 100644
--- a/collects/net/qp-unit.ss
+++ b/collects/net/qp-unit.ss
@@ -1,8 +1,8 @@
;;;
;;; ---- Quoted Printable Implementation
;;;
-;;; Copyright (C) 2002 by PLT.
-;;; Copyright (C) 2001 by Francisco Solsona.
+;;; Copyright (C) 2002 by PLT.
+;;; Copyright (C) 2001 by Francisco Solsona.
;;;
;;; This file was part of mime-plt.
@@ -31,143 +31,143 @@
(import)
(export qp^)
-
- ;; Exceptions:
- ;; String or input-port expected:
- (define-struct qp-error ())
- (define-struct (qp-wrong-input qp-error) ())
- (define-struct (qp-wrong-line-size qp-error) (size))
-
- ;; qp-encode : bytes -> bytes
- ;; returns the quoted printable representation of STR.
- (define qp-encode
- (lambda (str)
- (let ((out (open-output-bytes)))
- (qp-encode-stream (open-input-bytes str) out #"\r\n")
- (get-output-bytes out))))
-
- ;; qp-decode : string -> string
- ;; returns STR unqp.
- (define qp-decode
- (lambda (str)
- (let ((out (open-output-bytes)))
- (qp-decode-stream (open-input-bytes str) out)
- (get-output-bytes out))))
-
- (define qp-decode-stream
- (lambda (in out)
- (let loop ((ch (read-byte in)))
- (unless (eof-object? ch)
- (case ch
- ((61) ;; A "=", which is quoted-printable stuff
- (let ((next (read-byte in)))
- (cond
- ((eq? next 10)
- ;; Soft-newline -- drop it
- (void))
- ((eq? next 13)
- ;; Expect a newline for a soft CRLF...
- (let ((next-next (read-byte in)))
- (if (eq? next-next 10)
- ;; Good.
- (loop (read-byte in))
- ;; Not a LF? Well, ok.
- (loop next-next))))
- ((hex-digit? next)
- (let ((next-next (read-byte in)))
- (cond ((eof-object? next-next)
- (warning "Illegal qp sequence: `=~a'" next)
- (display "=" out)
- (display next out))
- ((hex-digit? next-next)
- ;; qp-encoded
- (write-byte (hex-bytes->byte next next-next)
- out))
- (else
- (warning "Illegal qp sequence: `=~a~a'" next next-next)
- (write-byte 61 out)
- (write-byte next out)
- (write-byte next-next out)))))
- (else
- ;; Warning: invalid
- (warning "Illegal qp sequence: `=~a'" next)
- (write-byte 61 out)
- (write-byte next out)))
- (loop (read-byte in))))
- (else
- (write-byte ch out)
- (loop (read-byte in))))))))
-
- (define warning
- (lambda (msg . args)
- (when #f
- (fprintf (current-error-port)
- (apply format msg args))
- (newline (current-error-port)))))
- (define (hex-digit? i)
- (vector-ref hex-values i))
+ ;; Exceptions:
+ ;; String or input-port expected:
+ (define-struct qp-error ())
+ (define-struct (qp-wrong-input qp-error) ())
+ (define-struct (qp-wrong-line-size qp-error) (size))
- (define hex-bytes->byte
- (lambda (b1 b2)
- (+ (* 16 (vector-ref hex-values b1))
- (vector-ref hex-values b2))))
+ ;; qp-encode : bytes -> bytes
+ ;; returns the quoted printable representation of STR.
+ (define qp-encode
+ (lambda (str)
+ (let ([out (open-output-bytes)])
+ (qp-encode-stream (open-input-bytes str) out #"\r\n")
+ (get-output-bytes out))))
- (define write-hex-bytes
- (lambda (byte p)
- (write-byte 61 p)
- (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
- (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
-
- (define re:blanks #rx#"[ \t]+$")
-
- (define qp-encode-stream
- (opt-lambda (in out [newline-string #"\n"])
- (let loop ([col 0])
- (if (= col 75)
- (begin
- ;; Soft newline:
- (write-byte 61 out)
- (display newline-string out)
- (loop 0))
- (let ([i (read-byte in)])
- (cond
- [(eof-object? i) (void)]
- [(or (= i 10) (= i 13))
- (write-byte i out)
- (loop 0)]
- [(or (<= 33 i 60) (<= 62 i 126)
- (and (or (= i 32) (= i 9))
- (not (let ([next (peek-byte in)])
- (or (eof-object? next) (= next 10) (= next 13))))))
- ;; single-byte mode:
- (write-byte i out)
- (loop (add1 col))]
- [(>= col 73)
- ;; need a soft newline first
- (write-byte 61 out)
- (display newline-string out)
- ;; now the octect
- (write-hex-bytes i out)
- (loop 3)]
- [else
- ;; an octect
- (write-hex-bytes i out)
- (loop (+ col 3))]))))))
+ ;; qp-decode : string -> string
+ ;; returns STR unqp.
+ (define qp-decode
+ (lambda (str)
+ (let ([out (open-output-bytes)])
+ (qp-decode-stream (open-input-bytes str) out)
+ (get-output-bytes out))))
- ;; Tables
- (define hex-values (make-vector 256 #f))
- (define hex-bytes (make-vector 16))
- (let loop ([i 0])
- (unless (= i 10)
- (vector-set! hex-values (+ i 48) i)
- (vector-set! hex-bytes i (+ i 48))
- (loop (add1 i))))
- (let loop ([i 0])
- (unless (= i 6)
- (vector-set! hex-values (+ i 65) (+ 10 i))
- (vector-set! hex-values (+ i 97) (+ 10 i))
- (vector-set! hex-bytes (+ 10 i) (+ i 65))
- (loop (add1 i)))))
+ (define qp-decode-stream
+ (lambda (in out)
+ (let loop ([ch (read-byte in)])
+ (unless (eof-object? ch)
+ (case ch
+ [(61) ;; A "=", which is quoted-printable stuff
+ (let ([next (read-byte in)])
+ (cond
+ [(eq? next 10)
+ ;; Soft-newline -- drop it
+ (void)]
+ [(eq? next 13)
+ ;; Expect a newline for a soft CRLF...
+ (let ([next-next (read-byte in)])
+ (if (eq? next-next 10)
+ ;; Good.
+ (loop (read-byte in))
+ ;; Not a LF? Well, ok.
+ (loop next-next)))]
+ [(hex-digit? next)
+ (let ([next-next (read-byte in)])
+ (cond [(eof-object? next-next)
+ (warning "Illegal qp sequence: `=~a'" next)
+ (display "=" out)
+ (display next out)]
+ [(hex-digit? next-next)
+ ;; qp-encoded
+ (write-byte (hex-bytes->byte next next-next)
+ out)]
+ [else
+ (warning "Illegal qp sequence: `=~a~a'" next next-next)
+ (write-byte 61 out)
+ (write-byte next out)
+ (write-byte next-next out)]))]
+ [else
+ ;; Warning: invalid
+ (warning "Illegal qp sequence: `=~a'" next)
+ (write-byte 61 out)
+ (write-byte next out)])
+ (loop (read-byte in)))]
+ [else
+ (write-byte ch out)
+ (loop (read-byte in))])))))
+
+ (define warning
+ (lambda (msg . args)
+ (when #f
+ (fprintf (current-error-port)
+ (apply format msg args))
+ (newline (current-error-port)))))
+
+ (define (hex-digit? i)
+ (vector-ref hex-values i))
+
+ (define hex-bytes->byte
+ (lambda (b1 b2)
+ (+ (* 16 (vector-ref hex-values b1))
+ (vector-ref hex-values b2))))
+
+ (define write-hex-bytes
+ (lambda (byte p)
+ (write-byte 61 p)
+ (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
+ (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
+
+ (define re:blanks #rx#"[ \t]+$")
+
+ (define qp-encode-stream
+ (opt-lambda (in out [newline-string #"\n"])
+ (let loop ([col 0])
+ (if (= col 75)
+ (begin
+ ;; Soft newline:
+ (write-byte 61 out)
+ (display newline-string out)
+ (loop 0))
+ (let ([i (read-byte in)])
+ (cond
+ [(eof-object? i) (void)]
+ [(or (= i 10) (= i 13))
+ (write-byte i out)
+ (loop 0)]
+ [(or (<= 33 i 60) (<= 62 i 126)
+ (and (or (= i 32) (= i 9))
+ (not (let ([next (peek-byte in)])
+ (or (eof-object? next) (= next 10) (= next 13))))))
+ ;; single-byte mode:
+ (write-byte i out)
+ (loop (add1 col))]
+ [(>= col 73)
+ ;; need a soft newline first
+ (write-byte 61 out)
+ (display newline-string out)
+ ;; now the octect
+ (write-hex-bytes i out)
+ (loop 3)]
+ [else
+ ;; an octect
+ (write-hex-bytes i out)
+ (loop (+ col 3))]))))))
+
+ ;; Tables
+ (define hex-values (make-vector 256 #f))
+ (define hex-bytes (make-vector 16))
+ (let loop ([i 0])
+ (unless (= i 10)
+ (vector-set! hex-values (+ i 48) i)
+ (vector-set! hex-bytes i (+ i 48))
+ (loop (add1 i))))
+ (let loop ([i 0])
+ (unless (= i 6)
+ (vector-set! hex-values (+ i 65) (+ 10 i))
+ (vector-set! hex-values (+ i 97) (+ 10 i))
+ (vector-set! hex-bytes (+ 10 i) (+ i 65))
+ (loop (add1 i)))))
;;; qp-unit.ss ends here
diff --git a/collects/net/sendmail-sig.ss b/collects/net/sendmail-sig.ss
index 3339c80..83cdbaf 100644
--- a/collects/net/sendmail-sig.ss
+++ b/collects/net/sendmail-sig.ss
@@ -2,4 +2,3 @@
send-mail-message/port
send-mail-message
(struct no-mail-recipients ()))
-
diff --git a/collects/net/sendmail-unit.ss b/collects/net/sendmail-unit.ss
index 45f3e42..162016a 100644
--- a/collects/net/sendmail-unit.ss
+++ b/collects/net/sendmail-unit.ss
@@ -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)))))
diff --git a/collects/net/smtp-sig.ss b/collects/net/smtp-sig.ss
index 314cdcb..4e4f711 100644
--- a/collects/net/smtp-sig.ss
+++ b/collects/net/smtp-sig.ss
@@ -3,4 +3,3 @@
smtp-send-message
smtp-send-message*
smtp-sending-end-of-message)
-
diff --git a/collects/net/smtp-unit.ss b/collects/net/smtp-unit.ss
index 233135c..8b1220b 100644
--- a/collects/net/smtp-unit.ss
+++ b/collects/net/smtp-unit.ss
@@ -1,131 +1,127 @@
(module smtp-unit (lib "a-unit.ss")
- (require (lib "kw.ss")
- "base64.ss"
- "smtp-sig.ss")
+ (require (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(import)
(export smtp^)
- (define smtp-sending-server (make-parameter "localhost"))
+ (define smtp-sending-server (make-parameter "localhost"))
- (define debug-via-stdio? #f)
+ (define debug-via-stdio? #f)
- (define crlf (string #\return #\linefeed))
+ (define crlf (string #\return #\linefeed))
- (define (log . args)
- ;; (apply printf args)
- (void))
+ (define (log . args)
+ ;; (apply printf args)
+ (void))
- (define (starts-with? l n)
- (and (>= (string-length l) (string-length n))
- (string=? n (substring l 0 (string-length n)))))
+ (define (starts-with? l n)
+ (and (>= (string-length l) (string-length n))
+ (string=? n (substring l 0 (string-length n)))))
- (define (check-reply r v w)
- (flush-output w)
- (let ([l (read-line r (if debug-via-stdio?
- 'linefeed
- 'return-linefeed))])
- (log "server: ~a~n" l)
- (if (eof-object? l)
- (error 'check-reply "got EOF")
- (let ([n (number->string v)])
- (unless (starts-with? l n)
- (error 'check-reply "expected reply ~a; got: ~a" v l))
- (let ([n- (string-append n "-")])
- (when (starts-with? l n-)
- ;; Multi-line reply. Go again.
- (check-reply r v w)))))))
+ (define (check-reply r v w)
+ (flush-output w)
+ (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))])
+ (log "server: ~a\n" l)
+ (if (eof-object? l)
+ (error 'check-reply "got EOF")
+ (let ([n (number->string v)])
+ (unless (starts-with? l n)
+ (error 'check-reply "expected reply ~a; got: ~a" v l))
+ (let ([n- (string-append n "-")])
+ (when (starts-with? l n-)
+ ;; Multi-line reply. Go again.
+ (check-reply r v w)))))))
- (define (protect-line l)
- ;; If begins with a dot, add one more
- (if (or (equal? l #"")
- (equal? l "")
- (and (string? l)
- (not (char=? #\. (string-ref l 0))))
- (and (bytes? l)
- (not (= (char->integer #\.) (bytes-ref l 0)))))
- l
- (if (bytes? l)
- (bytes-append #"." l)
- (string-append "." l))))
+ (define (protect-line l)
+ ;; If begins with a dot, add one more
+ (if (or (equal? l #"")
+ (equal? l "")
+ (and (string? l)
+ (not (char=? #\. (string-ref l 0))))
+ (and (bytes? l)
+ (not (= (char->integer #\.) (bytes-ref l 0)))))
+ l
+ (if (bytes? l)
+ (bytes-append #"." l)
+ (string-append "." l))))
- (define smtp-sending-end-of-message
- (make-parameter void
- (lambda (f)
- (unless (and (procedure? f)
- (procedure-arity-includes? f 0))
- (raise-type-error 'smtp-sending-end-of-message "thunk" f))
- f)))
-
- (define (smtp-send-message* r w sender recipients header message-lines
- auth-user auth-passwd)
- (with-handlers ([void (lambda (x)
- (close-input-port r)
- (close-output-port w)
- (raise x))])
- (check-reply r 220 w)
- (log "hello~n")
- (fprintf w "EHLO ~a~a" (smtp-sending-server) crlf)
- (check-reply r 250 w)
-
- (when auth-user
- (log "auth~n")
- (fprintf w "AUTH PLAIN ~a"
- ;; Encoding adds CRLF
- (base64-encode
- (string->bytes/latin-1
- (format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
- (check-reply r 235 w))
+ (define smtp-sending-end-of-message
+ (make-parameter void
+ (lambda (f)
+ (unless (and (procedure? f)
+ (procedure-arity-includes? f 0))
+ (raise-type-error 'smtp-sending-end-of-message "thunk" f))
+ f)))
- (log "from~n")
- (fprintf w "MAIL FROM:<~a>~a" sender crlf)
- (check-reply r 250 w)
-
- (log "to~n")
- (for-each
- (lambda (dest)
- (fprintf w "RCPT TO:<~a>~a" dest crlf)
- (check-reply r 250 w))
- recipients)
-
- (log "header~n")
- (fprintf w "DATA~a" crlf)
- (check-reply r 354 w)
- (fprintf w "~a" header)
- (for-each
- (lambda (l)
- (log "body: ~a~n" l)
- (fprintf w "~a~a" (protect-line l) crlf))
- message-lines)
+ (define (smtp-send-message* r w sender recipients header message-lines
+ auth-user auth-passwd)
+ (with-handlers ([void (lambda (x)
+ (close-input-port r)
+ (close-output-port w)
+ (raise x))])
+ (check-reply r 220 w)
+ (log "hello\n")
+ (fprintf w "EHLO ~a~a" (smtp-sending-server) crlf)
+ (check-reply r 250 w)
- ;; After we send the ".", then only break in an emergency
- ((smtp-sending-end-of-message))
+ (when auth-user
+ (log "auth\n")
+ (fprintf w "AUTH PLAIN ~a"
+ ;; Encoding adds CRLF
+ (base64-encode
+ (string->bytes/latin-1
+ (format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
+ (check-reply r 235 w))
- (log "dot~n")
- (fprintf w ".~a" crlf)
- (flush-output w)
- (check-reply r 250 w)
-
- (log "quit~n")
- (fprintf w "QUIT~a" crlf)
- (check-reply r 221 w)
-
- (close-output-port w)
- (close-input-port r)))
-
- (define smtp-send-message
- (lambda/kw (server sender recipients header message-lines
- #:key
- [port-no 25]
- [auth-user #f]
- [auth-passwd #f]
- [tcp-connect tcp-connect]
- #:body
- (#:optional [opt-port-no port-no]))
- (when (null? recipients)
- (error 'send-smtp-message "no receivers"))
- (let-values ([(r w) (if debug-via-stdio?
- (values (current-input-port) (current-output-port))
- (tcp-connect server opt-port-no))])
- (smtp-send-message* r w sender recipients header message-lines
- auth-user auth-passwd)))))
+ (log "from\n")
+ (fprintf w "MAIL FROM:<~a>~a" sender crlf)
+ (check-reply r 250 w)
+
+ (log "to\n")
+ (for-each
+ (lambda (dest)
+ (fprintf w "RCPT TO:<~a>~a" dest crlf)
+ (check-reply r 250 w))
+ recipients)
+
+ (log "header\n")
+ (fprintf w "DATA~a" crlf)
+ (check-reply r 354 w)
+ (fprintf w "~a" header)
+ (for-each
+ (lambda (l)
+ (log "body: ~a\n" l)
+ (fprintf w "~a~a" (protect-line l) crlf))
+ message-lines)
+
+ ;; After we send the ".", then only break in an emergency
+ ((smtp-sending-end-of-message))
+
+ (log "dot\n")
+ (fprintf w ".~a" crlf)
+ (flush-output w)
+ (check-reply r 250 w)
+
+ (log "quit\n")
+ (fprintf w "QUIT~a" crlf)
+ (check-reply r 221 w)
+
+ (close-output-port w)
+ (close-input-port r)))
+
+ (define smtp-send-message
+ (lambda/kw (server sender recipients header message-lines
+ #:key
+ [port-no 25]
+ [auth-user #f]
+ [auth-passwd #f]
+ [tcp-connect tcp-connect]
+ #:body
+ (#:optional [opt-port-no port-no]))
+ (when (null? recipients)
+ (error 'send-smtp-message "no receivers"))
+ (let-values ([(r w) (if debug-via-stdio?
+ (values (current-input-port) (current-output-port))
+ (tcp-connect server opt-port-no))])
+ (smtp-send-message* r w sender recipients header message-lines
+ auth-user auth-passwd)))))
diff --git a/collects/net/uri-codec-sig.ss b/collects/net/uri-codec-sig.ss
index 7c419c2..72d8e80 100644
--- a/collects/net/uri-codec-sig.ss
+++ b/collects/net/uri-codec-sig.ss
@@ -7,4 +7,4 @@
form-urlencoded-decode
alist->form-urlencoded
form-urlencoded->alist
- current-alist-separator-mode)
\ No newline at end of file
+ current-alist-separator-mode)
diff --git a/collects/net/uri-codec-unit.ss b/collects/net/uri-codec-unit.ss
index 0fb6673..0fe4804 100644
--- a/collects/net/uri-codec-unit.ss
+++ b/collects/net/uri-codec-unit.ss
@@ -1,11 +1,11 @@
-;; 1/2/2006: Added a mapping for uri path segments
-;; that allows more characters to remain decoded
+;; 1/2/2006: Added a mapping for uri path segments
+;; that allows more characters to remain decoded
;; -robby
#|
-People often seem to wonder why semicolons are the default in this code,
+People often seem to wonder why semicolons are the default in this code,
and not ampersands. Here's are the best answers we have:
From: Doug Orleans
@@ -50,9 +50,9 @@ Hash: SHA1
Danny Yoo:
- > > Just out of curiosity, why is current-alist-separator-mode using
- > > semicolons by default rather than ampersands? I understand that
- > > flexibility is nice, but this is the fifth time I've seen people hit this
+ > > Just out of curiosity, why is current-alist-separator-mode using
+ > > semicolons by default rather than ampersands? I understand that
+ > > flexibility is nice, but this is the fifth time I've seen people hit this
> > as a roadblock; shouldn't the default be what's most commonly used?
Robby Findler:
@@ -177,200 +177,200 @@ JALQefhDMCATcl2/bZL0bw==
(import)
(export uri-codec^)
-
- (define (self-map-char ch) (cons ch ch))
- (define (self-map-chars str) (map self-map-char (string->list str)))
- ;; The characters that always map to themselves
- (define alphanumeric-mapping
- (self-map-chars
- "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
+ (define (self-map-char ch) (cons ch ch))
+ (define (self-map-chars str) (map self-map-char (string->list str)))
- ;; Characters that sometimes map to themselves
- (define safe-mapping (self-map-chars "-_.!~*'()"))
+ ;; The characters that always map to themselves
+ (define alphanumeric-mapping
+ (self-map-chars
+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
- ;; The strict URI mapping
- (define uri-mapping (append alphanumeric-mapping safe-mapping))
+ ;; Characters that sometimes map to themselves
+ (define safe-mapping (self-map-chars "-_.!~*'()"))
- ;; The uri path segment mapping from RFC 3986
- (define uri-path-segment-mapping
- (append alphanumeric-mapping
- safe-mapping
- (map (λ (c) (cons c c)) (string->list "@+,=$&:"))))
+ ;; The strict URI mapping
+ (define uri-mapping (append alphanumeric-mapping safe-mapping))
- ;; The form-urlencoded mapping
- (define form-urlencoded-mapping
- `(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
+ ;; The uri path segment mapping from RFC 3986
+ (define uri-path-segment-mapping
+ (append alphanumeric-mapping
+ safe-mapping
+ (map (λ (c) (cons c c)) (string->list "@+,=$&:"))))
- (define (number->hex-string number)
- (define (hex n) (string-ref "0123456789ABCDEF" n))
- (string #\% (hex (quotient number 16)) (hex (modulo number 16))))
+ ;; The form-urlencoded mapping
+ (define form-urlencoded-mapping
+ `(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping))
- (define (hex-string->number hex-string)
- (string->number (substring hex-string 1 3) 16))
+ (define (number->hex-string number)
+ (define (hex n) (string-ref "0123456789ABCDEF" n))
+ (string #\% (hex (quotient number 16)) (hex (modulo number 16))))
- (define ascii-size 128)
+ (define (hex-string->number hex-string)
+ (string->number (substring hex-string 1 3) 16))
- ;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
- (define (make-codec-tables alist)
- (let ([encoding-table (build-vector ascii-size number->hex-string)]
- [decoding-table (build-vector ascii-size values)])
- (for-each (match-lambda
- [(orig . enc)
- (vector-set! encoding-table
- (char->integer orig)
- (string enc))
- (vector-set! decoding-table
- (char->integer enc)
- (char->integer orig))])
- alist)
- (values encoding-table decoding-table)))
+ (define ascii-size 128)
- (define-values (uri-encoding-vector uri-decoding-vector)
- (make-codec-tables uri-mapping))
+ ;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
+ (define (make-codec-tables alist)
+ (let ([encoding-table (build-vector ascii-size number->hex-string)]
+ [decoding-table (build-vector ascii-size values)])
+ (for-each (match-lambda
+ [(orig . enc)
+ (vector-set! encoding-table
+ (char->integer orig)
+ (string enc))
+ (vector-set! decoding-table
+ (char->integer enc)
+ (char->integer orig))])
+ alist)
+ (values encoding-table decoding-table)))
- (define-values (uri-path-segment-encoding-vector
- uri-path-segment-decoding-vector)
- (make-codec-tables uri-path-segment-mapping))
+ (define-values (uri-encoding-vector uri-decoding-vector)
+ (make-codec-tables uri-mapping))
- (define-values (form-urlencoded-encoding-vector
- form-urlencoded-decoding-vector)
- (make-codec-tables form-urlencoded-mapping))
+ (define-values (uri-path-segment-encoding-vector
+ uri-path-segment-decoding-vector)
+ (make-codec-tables uri-path-segment-mapping))
- ;; vector string -> string
- (define (encode table str)
- (apply string-append
- (map (lambda (byte)
- (cond
- [(< byte ascii-size)
- (vector-ref table byte)]
- [else (number->hex-string byte)]))
- (bytes->list (string->bytes/utf-8 str)))))
+ (define-values (form-urlencoded-encoding-vector
+ form-urlencoded-decoding-vector)
+ (make-codec-tables form-urlencoded-mapping))
- ;; vector string -> string
- (define (decode table str)
- (define internal-decode
- (match-lambda
- [() (list)]
- [(#\% (? hex-digit? char1) (? hex-digit? char2) . rest)
- ;; This used to consult the table again, but I think that's
- ;; wrong. For example %2b should produce +, not a space.
- (cons (string->number (string char1 char2) 16)
- (internal-decode rest))]
- [((? ascii-char? char) . rest)
- (cons
- (vector-ref table (char->integer char))
- (internal-decode rest))]
- [(char . rest)
- (append
- (bytes->list (string->bytes/utf-8 (string char)))
- (internal-decode rest))]))
- (bytes->string/utf-8
- (apply bytes (internal-decode (string->list str)))))
-
- (define (ascii-char? c)
- (< (char->integer c) ascii-size))
-
- (define (hex-digit? c)
- (or (char<=? #\0 c #\9)
- (char<=? #\a c #\f)
- (char<=? #\A c #\F)))
-
- ;; string -> string
- (define (uri-encode str)
- (encode uri-encoding-vector str))
+ ;; vector string -> string
+ (define (encode table str)
+ (apply string-append
+ (map (lambda (byte)
+ (cond
+ [(< byte ascii-size)
+ (vector-ref table byte)]
+ [else (number->hex-string byte)]))
+ (bytes->list (string->bytes/utf-8 str)))))
- ;; string -> string
- (define (uri-decode str)
- (decode uri-decoding-vector str))
-
- ;; string -> string
- (define (uri-path-segment-encode str)
- (encode uri-path-segment-encoding-vector str))
-
- ;; string -> string
- (define (uri-path-segment-decode str)
- (decode uri-path-segment-decoding-vector str))
+ ;; vector string -> string
+ (define (decode table str)
+ (define internal-decode
+ (match-lambda
+ [() (list)]
+ [(#\% (? hex-digit? char1) (? hex-digit? char2) . rest)
+ ;; This used to consult the table again, but I think that's
+ ;; wrong. For example %2b should produce +, not a space.
+ (cons (string->number (string char1 char2) 16)
+ (internal-decode rest))]
+ [((? ascii-char? char) . rest)
+ (cons
+ (vector-ref table (char->integer char))
+ (internal-decode rest))]
+ [(char . rest)
+ (append
+ (bytes->list (string->bytes/utf-8 (string char)))
+ (internal-decode rest))]))
+ (bytes->string/utf-8
+ (apply bytes (internal-decode (string->list str)))))
- ;; string -> string
- (define (form-urlencoded-encode str)
- (encode form-urlencoded-encoding-vector str))
+ (define (ascii-char? c)
+ (< (char->integer c) ascii-size))
- ;; string -> string
- (define (form-urlencoded-decode str)
- (decode form-urlencoded-decoding-vector str))
+ (define (hex-digit? c)
+ (or (char<=? #\0 c #\9)
+ (char<=? #\a c #\f)
+ (char<=? #\A c #\F)))
- ;; listof (cons string string) -> string
- ;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
- ;; listof (cons symbol string) -> string
- (define (alist->form-urlencoded args)
- (let* ([mode (current-alist-separator-mode)]
- [format-one
- (lambda (arg)
- (let* ([name (car arg)]
- [value (cdr arg)])
- (string-append (form-urlencoded-encode (symbol->string name))
- "="
- (form-urlencoded-encode value))))]
- [strs (let loop ([args args])
- (cond
- [(null? args) null]
- [(null? (cdr args)) (list (format-one (car args)))]
- [else (list* (format-one (car args))
- (if (eq? mode 'amp) "&" ";")
- (loop (cdr args)))]))])
- (apply string-append strs)))
+ ;; string -> string
+ (define (uri-encode str)
+ (encode uri-encoding-vector str))
- ;; string -> listof (cons string string)
- ;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
- (define (form-urlencoded->alist str)
- (define key-regexp #rx"[^=]*")
- (define value-regexp (case (current-alist-separator-mode)
- [(semi) #rx"[^;]*"]
- [(amp) #rx"[^&]*"]
- [else #rx"[^&;]*"]))
- (define (next-key str start)
- (and (< start (string-length str))
- (match (regexp-match-positions key-regexp str start)
- [((start . end))
- (vector (let ([s (form-urlencoded-decode
- (substring str start end))])
- (string->symbol s))
- (add1 end))]
- [#f #f])))
- (define (next-value str start)
- (and (< start (string-length str))
- (match (regexp-match-positions value-regexp str start)
- [((start . end))
- (vector (form-urlencoded-decode (substring str start end))
- (add1 end))]
- [#f #f])))
- (define (next-pair str start)
- (match (next-key str start)
- [#(key start)
- (match (next-value str start)
- [#(value start)
- (vector (cons key value) start)]
- [#f
- (vector (cons key "") (string-length str))])]
- [#f #f]))
- (let loop ([start 0]
- [end (string-length str)]
- [make-alist (lambda (x) x)])
- (if (>= start end)
- (make-alist '())
- (match (next-pair str start)
- [#(pair next-start)
- (loop next-start end (lambda (x) (make-alist (cons pair x))))]
- [#f (make-alist '())]))))
+ ;; string -> string
+ (define (uri-decode str)
+ (decode uri-decoding-vector str))
- (define current-alist-separator-mode
- (make-parameter 'amp-or-semi
- (lambda (s)
- (unless (memq s '(amp semi amp-or-semi))
- (raise-type-error 'current-alist-separator-mode
- "'amp, 'semi, or 'amp-or-semi"
- s))
- s))))
+ ;; string -> string
+ (define (uri-path-segment-encode str)
+ (encode uri-path-segment-encoding-vector str))
+
+ ;; string -> string
+ (define (uri-path-segment-decode str)
+ (decode uri-path-segment-decoding-vector str))
+
+ ;; string -> string
+ (define (form-urlencoded-encode str)
+ (encode form-urlencoded-encoding-vector str))
+
+ ;; string -> string
+ (define (form-urlencoded-decode str)
+ (decode form-urlencoded-decoding-vector str))
+
+ ;; listof (cons string string) -> string
+ ;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
+ ;; listof (cons symbol string) -> string
+ (define (alist->form-urlencoded args)
+ (let* ([mode (current-alist-separator-mode)]
+ [format-one
+ (lambda (arg)
+ (let* ([name (car arg)]
+ [value (cdr arg)])
+ (string-append (form-urlencoded-encode (symbol->string name))
+ "="
+ (form-urlencoded-encode value))))]
+ [strs (let loop ([args args])
+ (cond
+ [(null? args) null]
+ [(null? (cdr args)) (list (format-one (car args)))]
+ [else (list* (format-one (car args))
+ (if (eq? mode 'amp) "&" ";")
+ (loop (cdr args)))]))])
+ (apply string-append strs)))
+
+ ;; string -> listof (cons string string)
+ ;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris
+ (define (form-urlencoded->alist str)
+ (define key-regexp #rx"[^=]*")
+ (define value-regexp (case (current-alist-separator-mode)
+ [(semi) #rx"[^;]*"]
+ [(amp) #rx"[^&]*"]
+ [else #rx"[^&;]*"]))
+ (define (next-key str start)
+ (and (< start (string-length str))
+ (match (regexp-match-positions key-regexp str start)
+ [((start . end))
+ (vector (let ([s (form-urlencoded-decode
+ (substring str start end))])
+ (string->symbol s))
+ (add1 end))]
+ [#f #f])))
+ (define (next-value str start)
+ (and (< start (string-length str))
+ (match (regexp-match-positions value-regexp str start)
+ [((start . end))
+ (vector (form-urlencoded-decode (substring str start end))
+ (add1 end))]
+ [#f #f])))
+ (define (next-pair str start)
+ (match (next-key str start)
+ [#(key start)
+ (match (next-value str start)
+ [#(value start)
+ (vector (cons key value) start)]
+ [#f
+ (vector (cons key "") (string-length str))])]
+ [#f #f]))
+ (let loop ([start 0]
+ [end (string-length str)]
+ [make-alist (lambda (x) x)])
+ (if (>= start end)
+ (make-alist '())
+ (match (next-pair str start)
+ [#(pair next-start)
+ (loop next-start end (lambda (x) (make-alist (cons pair x))))]
+ [#f (make-alist '())]))))
+
+ (define current-alist-separator-mode
+ (make-parameter 'amp-or-semi
+ (lambda (s)
+ (unless (memq s '(amp semi amp-or-semi))
+ (raise-type-error 'current-alist-separator-mode
+ "'amp, 'semi, or 'amp-or-semi"
+ s))
+ s))))
;;; uri-codec-unit.ss ends here
diff --git a/collects/net/url-sig.ss b/collects/net/url-sig.ss
index 22d55b0..cf4269e 100644
--- a/collects/net/url-sig.ss
+++ b/collects/net/url-sig.ss
@@ -12,4 +12,3 @@
combine-url/relative
url-exception?
current-proxy-servers)
-
diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss
index b04e20b..9a02885 100644
--- a/collects/net/url-unit.ss
+++ b/collects/net/url-unit.ss
@@ -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]*"
- "(?:" ; 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]*"
+ "(?:" ; 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))))]))
+
+ ))