diff --git a/collects/net/base64-sig.ss b/collects/net/base64-sig.ss
index 3e6a42278e..4dcb01d8c4 100644
--- a/collects/net/base64-sig.ss
+++ b/collects/net/base64-sig.ss
@@ -1,4 +1,3 @@
-
#lang scheme/signature
base64-filename-safe
diff --git a/collects/net/base64.ss b/collects/net/base64.ss
index 10ee7d6cff..3e33bfcc78 100644
--- a/collects/net/base64.ss
+++ b/collects/net/base64.ss
@@ -1,8 +1,6 @@
-(module base64 mzscheme
- (require mzlib/unit
- "base64-sig.ss"
- "base64-unit.ss")
+#lang scheme/base
+(require scheme/unit "base64-sig.ss" "base64-unit.ss")
- (define-values/invoke-unit/infer base64@)
+(define-values/invoke-unit/infer base64@)
- (provide-signature-elements base64^))
+(provide-signature-elements base64^)
diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss
index 2bbe23cae9..ce92d4a38f 100644
--- a/collects/net/cgi-unit.ss
+++ b/collects/net/cgi-unit.ss
@@ -1,214 +1,210 @@
#lang scheme/unit
+(require "cgi-sig.ss" "uri-codec.ss")
- (require mzlib/etc
- "cgi-sig.ss"
- "uri-codec.ss")
+(import)
+(export cgi^)
- (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)
+ (form-urlencoded-decode (list->string chars)))
- (define (query-chars->string chars)
- (form-urlencoded-decode (list->string chars)))
+;; 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 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 ([l `("Content-type: text/html"
+ ""
+ ""
+ ""
+ ""
+ ,(sa "" title "")
+ ""
+ ""
+ ,(sa "")
+ ""
+ ,@body-lines
+ ""
+ ""
+ "")])
+ (display l)
+ (newline))))
- (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))])
+ (cond [(and eof? (not name)) null]
+ [(and eof? name) (list (cons name value))]
+ [else (cons (cons name value) (get-bindings/post))])))
- ;; 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) (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)
+ (or (getenv "REQUEST_METHOD")
+ (error 'get-cgi-method "no REQUEST_METHOD environment variable")))
- ;; get-cgi-method : () -> string
- ;; -- string is either GET or POST (though future extension is possible)
- (define (get-cgi-method)
- (or (getenv "REQUEST_METHOD")
- (error 'get-cgi-method "no REQUEST_METHOD environment variable")))
-
- ;; 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/cgi.ss b/collects/net/cgi.ss
index 1dca70b60a..ff7afe44e5 100644
--- a/collects/net/cgi.ss
+++ b/collects/net/cgi.ss
@@ -1,6 +1,6 @@
-(module cgi mzscheme
- (require mzlib/unit "cgi-sig.ss" "cgi-unit.ss")
+#lang scheme/base
+(require scheme/unit "cgi-sig.ss" "cgi-unit.ss")
- (define-values/invoke-unit/infer cgi@)
+(define-values/invoke-unit/infer cgi@)
- (provide-signature-elements cgi^))
+(provide-signature-elements cgi^)
diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss
index 4ebbf56386..8eb31e9b41 100644
--- a/collects/net/cookie-unit.ss
+++ b/collects/net/cookie-unit.ss
@@ -50,279 +50,274 @@
#lang scheme/unit
- (require mzlib/etc
- mzlib/list
- srfi/13/string
- srfi/14/char-set
- "cookie-sig.ss")
+(require srfi/13/string srfi/14/char-set "cookie-sig.ss")
- (import)
- (export cookie^)
+(import)
+(export cookie^)
- (define-struct cookie (name value comment domain max-age path secure version) #:mutable)
- (define-struct (cookie-error exn:fail) ())
+(define-struct cookie
+ (name value comment domain max-age path secure version) #:mutable)
+(define-struct (cookie-error exn:fail) ())
- ;; 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 (error* fmt . args)
- (raise (make-cookie-error (apply format fmt args)
- (current-continuation-marks))))
+;; 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 (error* fmt . args)
+ (raise (make-cookie-error (apply format fmt args)
+ (current-continuation-marks))))
- ;; The syntax for the Set-Cookie response header is
- ;; set-cookie = "Set-Cookie:" cookies
- ;; cookies = 1#cookie
- ;; cookie = NAME "=" VALUE *(";" cookie-av)
- ;; NAME = attr
- ;; VALUE = value
- ;; cookie-av = "Comment" "=" value
- ;; | "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)
- (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
- )))
+;; The syntax for the Set-Cookie response header is
+;; set-cookie = "Set-Cookie:" cookies
+;; cookies = 1#cookie
+;; cookie = NAME "=" VALUE *(";" cookie-av)
+;; NAME = attr
+;; VALUE = value
+;; cookie-av = "Comment" "=" value
+;; | "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)
+ (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
+ )))
- ;;!
- ;;
- ;; (function (print-cookie cookie))
- ;;
- ;; (param cookie Cookie-structure "The cookie to return as a string")
- ;;
- ;; 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 cookie)
+;;!
+;;
+;; (function (print-cookie cookie))
+;;
+;; (param cookie Cookie-structure "The cookie to return as a string")
+;;
+;; 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 cookie)
+ (define (format-if fmt val) (and val (format fmt val)))
+ (unless (cookie? cookie) (error* "cookie expected, received: ~a" cookie))
+ (string-join
+ (filter values
+ (list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
+ (format-if "Comment=~a" (cookie-comment cookie))
+ (format-if "Domain=~a" (cookie-domain cookie))
+ (format-if "Max-Age=~a" (cookie-max-age cookie))
+ (format-if "Path=~a" (cookie-path cookie))
+ (and (cookie-secure cookie) "Secure")
+ (format "Version=~a" (or (cookie-version cookie) 1))))
+ "; "))
+
+(define (cookie:add-comment cookie pre-comment)
+ (let ([comment (to-rfc2109:value pre-comment)])
(unless (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)))))
- "; "))
+ (set-cookie-comment! cookie comment)
+ cookie))
- (define (cookie:add-comment cookie pre-comment)
- (let ([comment (to-rfc2109:value pre-comment)])
- (unless (cookie? cookie)
- (error* "cookie expected, received: ~a" cookie))
- (set-cookie-comment! cookie comment)
- cookie))
+(define (cookie:add-domain cookie domain)
+ (unless (valid-domain? domain)
+ (error* "invalid domain: ~a" domain))
+ (unless (cookie? cookie)
+ (error* "cookie expected, received: ~a" cookie))
+ (set-cookie-domain! cookie domain)
+ cookie)
- (define (cookie:add-domain cookie domain)
- (unless (valid-domain? domain)
- (error* "invalid domain: ~a" domain))
+(define (cookie:add-max-age cookie seconds)
+ (unless (and (integer? seconds) (not (negative? seconds)))
+ (error* "invalid Max-Age for cookie: ~a" seconds))
+ (unless (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)
(error* "cookie expected, received: ~a" cookie))
- (set-cookie-domain! cookie domain)
- cookie)
+ (set-cookie-path! cookie path)
+ cookie))
- (define (cookie:add-max-age cookie seconds)
- (unless (and (integer? seconds) (not (negative? seconds)))
- (error* "invalid Max-Age for cookie: ~a" seconds))
- (unless (cookie? cookie)
- (error* "cookie expected, received: ~a" cookie))
- (set-cookie-max-age! cookie seconds)
- cookie)
+(define (cookie:secure cookie secure?)
+ (unless (boolean? secure?)
+ (error* "invalid argument (boolean expected), received: ~a" secure?))
+ (unless (cookie? cookie)
+ (error* "cookie expected, received: ~a" cookie))
+ (set-cookie-secure! cookie secure?)
+ cookie)
- (define (cookie:add-path cookie pre-path)
- (let ([path (to-rfc2109:value pre-path)])
- (unless (cookie? cookie)
- (error* "cookie expected, received: ~a" cookie))
- (set-cookie-path! cookie path)
- cookie))
-
- (define (cookie:secure cookie secure?)
- (unless (boolean? secure?)
- (error* "invalid argument (boolean expected), received: ~a" secure?))
- (unless (cookie? cookie)
- (error* "cookie expected, received: ~a" cookie))
- (set-cookie-secure! cookie secure?)
- cookie)
-
- (define (cookie:version cookie version)
- (unless (integer? version)
- (error* "unsupported version: ~a" version))
- (unless (cookie? cookie)
- (error* "cookie expected, received: ~a" cookie))
- (set-cookie-version! cookie version)
- cookie)
+(define (cookie:version cookie version)
+ (unless (integer? version)
+ (error* "unsupported version: ~a" version))
+ (unless (cookie? cookie)
+ (error* "cookie expected, received: ~a" cookie))
+ (set-cookie-version! cookie version)
+ cookie)
- ;; Parsing the Cookie header:
+;; Parsing the Cookie header:
- (define char-set:all-but=
- (char-set-difference char-set:full (string->char-set "=")))
+(define char-set:all-but=
+ (char-set-difference char-set:full (string->char-set "=")))
- (define char-set:all-but-semicolon
- (char-set-difference char-set:full (string->char-set ";")))
+(define char-set:all-but-semicolon
+ (char-set-difference char-set:full (string->char-set ";")))
- ;;!
- ;;
- ;; (function (get-all-results name cookies))
- ;;
- ;; Auxiliar procedure that returns all values associated with
- ;; `name' in the association list (cookies).
- (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)))))))
+;;!
+;;
+;; (function (get-all-results name cookies))
+;;
+;; Auxiliar procedure that returns all values associated with
+;; `name' in the association list (cookies).
+(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 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)))
+;; 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)))
- ;;!
- ;;
- ;; (function (get-cookie/single name cookies))
- ;;
- ;; (param name String "The name of the cookie we are looking for")
- ;; (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 name cookies)
- (let ([cookies (get-cookie name cookies)])
- (and (not (null? cookies)) (car cookies))))
+;;!
+;;
+;; (function (get-cookie/single name cookies))
+;;
+;; (param name String "The name of the cookie we are looking for")
+;; (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 name cookies)
+ (let ([cookies (get-cookie name cookies)])
+ (and (not (null? cookies)) (car cookies))))
- ;;;;;
- ;; Auxiliary procedures
- ;;;;;
+;;;;;
+;; Auxiliary procedures
+;;;;;
- ;; token = 1*
- ;;
- ;; tspecials = "(" | ")" | "<" | ">" | "@"
- ;; | "," | ";" | ":" | "\" | <">
- ;; | "/" | "[" | "]" | "?" | "="
- ;; | "{" | "}" | SP | HT
- (define char-set:tspecials
- (char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
- char-set:whitespace
- (char-set #\tab)))
+;; token = 1*
+;;
+;; tspecials = "(" | ")" | "<" | ">" | "@"
+;; | "," | ";" | ":" | "\" | <">
+;; | "/" | "[" | "]" | "?" | "="
+;; | "{" | "}" | SP | HT
+(define char-set:tspecials
+ (char-set-union (string->char-set "()<>@,;:\\\"/[]?={}")
+ char-set:whitespace
+ (char-set #\tab)))
- (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: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))
- ;; token? : string -> boolean
- ;;
- ;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
- (define (rfc2068:token? s)
- (string-every char-set:token s))
+;; token? : string -> boolean
+;;
+;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
+(define (rfc2068:token? s)
+ (string-every char-set:token s))
- ;;!
- ;;
- ;; (function (quoted-string? s))
- ;;
- ;; (param s String "The string to check")
- ;;
- ;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
- ;; quoted-string = ( <"> *(qdtext) <"> )
- ;; qdtext = >
- ;;
- ;; The backslash character ("\") may be used as a single-character quoting
- ;; mechanism only within quoted-string and comment constructs.
- ;;
- ;; 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? s)
- (if (regexp-match
- #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
- s)
- s
- #f))
+;;!
+;;
+;; (function (quoted-string? s))
+;;
+;; (param s String "The string to check")
+;;
+;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
+;; quoted-string = ( <"> *(qdtext) <"> )
+;; qdtext = >
+;;
+;; The backslash character ("\") may be used as a single-character quoting
+;; mechanism only within quoted-string and comment constructs.
+;;
+;; 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? s)
+ (and (regexp-match?
+ #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
+ s)
+ s))
- ;; value: token | quoted-string
- (define (rfc2109:value? s)
- (or (rfc2068:token? s) (rfc2068:quoted-string? s)))
+;; 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
- (define (convert-to-quoted str)
- (string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
+;; convert-to-quoted : string -> quoted-string?
+;; 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?
- (define (to-rfc2109:value s)
- (cond
- [(not (string? s))
- (error* "expected string, given: ~e" s)]
+;; string -> rfc2109:value?
+(define (to-rfc2109:value s)
+ (cond
+ [(not (string? s))
+ (error* "expected string, given: ~e" s)]
- ;; for backwards compatibility, just use the given string if it will work
- [(rfc2068:token? s) s]
- [(rfc2068:quoted-string? s) s]
+ ;; for backwards compatibility, just use the given string if it will work
+ [(rfc2068:token? s) s]
+ [(rfc2068:quoted-string? s) s]
- ;; ... but if it doesn't work (i.e., it's just a normal message) then try
- ;; to convert it into a representation that will work
- [(rfc2068:quoted-string? (convert-to-quoted s))
- => (λ (x) x)]
- [else
- (error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
+ ;; ... but if it doesn't work (i.e., it's just a normal message) then try
+ ;; to convert it into a representation that will work
+ [(rfc2068:quoted-string? (convert-to-quoted s))
+ => (λ (x) x)]
+ [else
+ (error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
- ;;!
- ;;
- ;; (function (cookie-string? s))
- ;;
- ;; (param s String "String to check")
- ;;
- ;; Returns whether this is a valid string to use as the value or the
- ;; name (depending on value?) of an HTTP cookie.
- (define cookie-string?
- (opt-lambda (s (value? #t))
- (unless (string? s)
- (error* "string expected, received: ~a" s))
- (if value?
- (rfc2109:value? s)
- ;; name: token
- (rfc2068:token? s))))
+;;!
+;;
+;; (function (cookie-string? s))
+;;
+;; (param s String "String to check")
+;;
+;; Returns whether this is a valid string to use as the value or the
+;; name (depending on value?) of an HTTP cookie.
+(define (cookie-string? s [value? #t])
+ (unless (string? s)
+ (error* "string expected, received: ~a" s))
+ (if value?
+ (rfc2109:value? s)
+ ;; name: token
+ (rfc2068:token? s)))
- ;; 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)])
- (char-set-adjoin!
- (char-set-union char-set:digit a-z-lowercase a-z-uppercase)
- #\.)))
+;; 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)])
+ (char-set-adjoin!
+ (char-set-union char-set:digit a-z-lowercase a-z-uppercase)
+ #\.)))
- (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-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)))
+(define (valid-path? v)
+ (and (string? v) (rfc2109:value? v)))
;;; cookie-unit.ss ends here
diff --git a/collects/net/cookie.ss b/collects/net/cookie.ss
index 6b900fe299..449ec3ccae 100644
--- a/collects/net/cookie.ss
+++ b/collects/net/cookie.ss
@@ -1,6 +1,6 @@
-(module cookie mzscheme
- (require mzlib/unit "cookie-sig.ss" "cookie-unit.ss")
+#lang scheme/base
+(require scheme/unit "cookie-sig.ss" "cookie-unit.ss")
- (provide-signature-elements cookie^)
+(provide-signature-elements cookie^)
- (define-values/invoke-unit/infer cookie@))
+(define-values/invoke-unit/infer cookie@)
diff --git a/collects/net/dns-unit.ss b/collects/net/dns-unit.ss
index ab7536da6a..8a52d7603a 100644
--- a/collects/net/dns-unit.ss
+++ b/collects/net/dns-unit.ss
@@ -1,345 +1,338 @@
#lang scheme/unit
- (require mzlib/list mzlib/process "dns-sig.ss"
- scheme/udp)
+(require "dns-sig.ss" scheme/system scheme/udp)
- (import)
- (export dns^)
+(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])
+ (if (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)))
+ (loop (sub1 len) (cdr start) (cons (car start) accum))))]
+ [else
+ ;; Compression offset
+ (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
+ (cadr start))])
+ (let-values ([(s ignore-start)
+ (parse-name (list-tail reply offset) reply)])
+ (values s (cddr start))))])))
- (define (parse-rr start reply)
- (let-values ([(name start) (parse-name start reply)])
- (let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
- types))]
- [start (cddr start)]
- ;;
- [class (car (cossa (octet-pair->number (car start) (cadr start))
- classes))]
- [start (cddr start)]
- ;;
- [ttl (octet-quad->number (car start) (cadr start)
- (caddr start) (cadddr start))]
- [start (cddddr start)]
- ;;
- [len (octet-pair->number (car start) (cadr start))]
- [start (cddr start)])
- ;; Extract next len bytes for data:
- (let loop ([len len] [start start] [accum null])
- (if (zero? len)
- (values (list name type class ttl (reverse accum))
- start)
- (loop (sub1 len) (cdr start) (cons (car start) accum)))))))
+(define (parse-rr start reply)
+ (let-values ([(name start) (parse-name start reply)])
+ (let* ([type (car (cossa (octet-pair->number (car start) (cadr start))
+ types))]
+ [start (cddr start)]
+ ;;
+ [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)]
- ;;
- [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 ([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 ([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 ([start (list-tail reply 12)])
+ (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
+ [(ans start) (parse-n parse-rr start reply an-count)]
+ [(nss start) (parse-n parse-rr start reply ns-count)]
+ [(ars start) (parse-n parse-rr start reply ar-count)])
+ (unless (null? start)
+ (error 'dns-query "error parsing server reply"))
+ (values (positive? (bitwise-and #x4 v0))
+ qds ans nss ars reply)))))))
- (define cache (make-hasheq))
- (define (dns-query/cache nameserver addr type class)
- (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
- (let ([v (hash-ref cache key (lambda () #f))])
- (if v
- (apply values v)
- (let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
- (hash-set! cache key (list auth? qds ans nss ars reply))
- (values auth? qds ans nss ars reply))))))
+(define cache (make-hasheq))
+(define (dns-query/cache nameserver addr type class)
+ (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
+ (let ([v (hash-ref cache key (lambda () #f))])
+ (if v
+ (apply values v)
+ (let-values ([(auth? qds ans nss ars reply)
+ (dns-query nameserver addr type class)])
+ (hash-set! 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 (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 (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 (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 (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 (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 (get-a-list-from-ans ans)
+ (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a))
+ ans))
- (define (dns-get-address nameserver addr)
- (or (try-forwarding
- (lambda (nameserver)
- (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
- (values (and (positive? (length (get-a-list-from-ans ans)))
- (let ([s (rr-data (car (get-a-list-from-ans ans)))])
- (ip->string s)))
- ars auth?)))
- nameserver)
- (error 'dns-get-address "bad address")))
+(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")))
- (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")))
+(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")))
- (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))))))))]
- [(windows)
- (let ([nslookup (find-executable-path "nslookup.exe" #f)])
- (and nslookup
- (let-values ([(pin pout pid perr proc)
- (apply
- values
- (process/ports
- #f (open-input-file "NUL") (current-error-port)
- nslookup))])
- (let loop ([name #f][ip #f][try-ip? #f])
- (let ([line (read-line pin 'any)])
- (cond [(eof-object? line)
- (close-input-port pin)
- (proc 'wait)
- (or ip name)]
- [(and (not name)
- (regexp-match #rx"^Default Server: +(.*)$"
- line))
- => (lambda (m) (loop (cadr m) #f #t))]
- [(and try-ip?
- (regexp-match #rx"^Address: +(.*)$"
- line))
- => (lambda (m) (loop name (cadr m) #f))]
- [else (loop name ip #f)]))))))]
- [else #f]))
+(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))))))))]
+ [(windows)
+ (let ([nslookup (find-executable-path "nslookup.exe" #f)])
+ (and nslookup
+ (let-values ([(pin pout pid perr proc)
+ (apply
+ values
+ (process/ports
+ #f (open-input-file "NUL") (current-error-port)
+ nslookup))])
+ (let loop ([name #f] [ip #f] [try-ip? #f])
+ (let ([line (read-line pin 'any)])
+ (cond [(eof-object? line)
+ (close-input-port pin)
+ (proc 'wait)
+ (or ip name)]
+ [(and (not name)
+ (regexp-match #rx"^Default Server: +(.*)$" line))
+ => (lambda (m) (loop (cadr m) #f #t))]
+ [(and try-ip?
+ (regexp-match #rx"^Address: +(.*)$" line))
+ => (lambda (m) (loop name (cadr m) #f))]
+ [else (loop name ip #f)]))))))]
+ [else #f]))
diff --git a/collects/net/dns.ss b/collects/net/dns.ss
index 2169f09f93..6d58459ee4 100644
--- a/collects/net/dns.ss
+++ b/collects/net/dns.ss
@@ -1,6 +1,6 @@
-(module dns mzscheme
- (require mzlib/unit "dns-sig.ss" "dns-unit.ss")
+#lang scheme/base
+(require scheme/unit "dns-sig.ss" "dns-unit.ss")
- (define-values/invoke-unit/infer dns@)
+(define-values/invoke-unit/infer dns@)
- (provide-signature-elements dns^))
+(provide-signature-elements dns^)
diff --git a/collects/net/ftp.ss b/collects/net/ftp.ss
index 9685165d27..9a704ca76e 100644
--- a/collects/net/ftp.ss
+++ b/collects/net/ftp.ss
@@ -1,6 +1,6 @@
-(module ftp mzscheme
- (require mzlib/unit "ftp-sig.ss" "ftp-unit.ss")
+#lang scheme/base
+(require scheme/unit "ftp-sig.ss" "ftp-unit.ss")
- (define-values/invoke-unit/infer ftp@)
+(define-values/invoke-unit/infer ftp@)
- (provide-signature-elements ftp^))
+(provide-signature-elements ftp^)
diff --git a/collects/net/head-unit.ss b/collects/net/head-unit.ss
index 67c43484bc..7b42b5a363 100644
--- a/collects/net/head-unit.ss
+++ b/collects/net/head-unit.ss
@@ -1,349 +1,345 @@
#lang scheme/unit
- (require mzlib/date mzlib/string "head-sig.ss")
+(require mzlib/date mzlib/string "head-sig.ss")
- (import)
- (export head^)
+(import)
+(export head^)
- ;; NB: I've done a copied-code adaptation of a number of these definitions
- ;; into "bytes-compatible" versions. Finishing the rest will require some
- ;; kind of interface decision---that is, when you don't supply a header,
- ;; should the resulting operation be string-centric or bytes-centric?
- ;; Easiest just to stop here.
- ;; -- JBC 2006-07-31
+;; NB: I've done a copied-code adaptation of a number of these definitions
+;; into "bytes-compatible" versions. Finishing the rest will require some
+;; kind of interface decision---that is, when you don't supply a header,
+;; should the resulting operation be string-centric or bytes-centric?
+;; Easiest just to stop here.
+;; -- JBC 2006-07-31
- (define CRLF (string #\return #\newline))
- (define CRLF/bytes #"\r\n")
+(define CRLF (string #\return #\newline))
+(define CRLF/bytes #"\r\n")
- (define empty-header CRLF)
- (define empty-header/bytes CRLF/bytes)
+(define empty-header CRLF)
+(define empty-header/bytes CRLF/bytes)
- (define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
- (define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
+(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
+(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:")
- (define re:continue (regexp "^[ \t\v]"))
- (define re:continue/bytes #rx#"^[ \t\v]")
+(define re:continue (regexp "^[ \t\v]"))
+(define re:continue/bytes #rx#"^[ \t\v]")
- (define (validate-header s)
- (if (bytes? s)
- ;; legal char check not needed per rfc 2822, IIUC.
- (let ([len (bytes-length s)])
+(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)
- (bytes=? CRLF/bytes (subbytes s offset len)))
+ (string=? CRLF (substring 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)])
+ [(= 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/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)))]))))))
+ (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 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 (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 (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 (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 (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 (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 (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))))))
- (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
- ;; 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)
+(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 "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)))))
+ (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 (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"))
+(define (data-lines->data datas)
+ (splice datas "\r\n\t"))
- ;; Extracting Addresses ;;
+;; 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 blank "[ \t\n\r\v]")
+(define nonblank "[^ \t\n\r\v]")
+(define re:all-blank (regexp (format "^~a*$" blank)))
+(define re:quoted (regexp "\"[^\"]*\""))
+(define re:parened (regexp "[(][^)]*[)]"))
+(define re:comma (regexp ","))
+(define re:comma-separated (regexp "([^,]*),(.*)"))
- (define (extract-addresses s form)
- (unless (memq form '(name address full all))
- (raise-type-error 'extract-addresses
- "form: 'name, 'address, 'full, or 'all"
- form))
- (if (or (not s) (regexp-match re:all-blank s))
- null
- (let loop ([prefix ""][s s])
- ;; Which comes first - a quote or a comma?
- (let* ([mq1 (regexp-match-positions re:quoted s)]
- [mq2 (regexp-match-positions re:parened s)]
- [mq (if (and mq1 mq2)
- (if (< (caar mq1) (caar mq2))
- mq1
- mq2)
- (or mq1 mq2))]
- [mc (regexp-match-positions re:comma s)])
- (if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
- ;; Quote contains a comma
- (loop (string-append
- prefix
- (substring s 0 (cdar mq)))
- (substring s (cdar mq) (string-length s)))
- ;; Normal comma parsing:
- (let ([m (regexp-match re:comma-separated s)])
- (if m
- (let ([n (extract-one-name (string-append prefix (cadr m)) form)]
- [rest (extract-addresses (caddr m) form)])
- (cons n rest))
- (let ([n (extract-one-name (string-append prefix s) form)])
- (list n)))))))))
+(define (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 (select-result form name addr full)
+ (case form
+ [(name) name]
+ [(address) addr]
+ [(full) full]
+ [(all) (list name addr full)]))
- (define (one-result form s)
- (select-result form s s s))
+(define (one-result form s)
+ (select-result form s s s))
- (define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
- (define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
- (define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
- (define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
- (define re:double-less (regexp "<.*<"))
- (define re:double-greater (regexp ">.*>"))
- (define re:bad-chars (regexp "[,\"()<>]"))
- (define re:tail-blanks (regexp (format "~a+$" blank)))
- (define re:head-blanks (regexp (format "^~a+" blank)))
+(define 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-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-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 (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/head.ss b/collects/net/head.ss
index 41687311cf..3118f3652e 100644
--- a/collects/net/head.ss
+++ b/collects/net/head.ss
@@ -1,6 +1,6 @@
-(module head mzscheme
- (require mzlib/unit "head-sig.ss" "head-unit.ss")
+#lang scheme/base
+(require scheme/unit "head-sig.ss" "head-unit.ss")
- (define-values/invoke-unit/infer head@)
+(define-values/invoke-unit/infer head@)
- (provide-signature-elements head^))
+(provide-signature-elements head^)
diff --git a/collects/net/imap-unit.ss b/collects/net/imap-unit.ss
index 14cf2f479c..b0800eb451 100644
--- a/collects/net/imap-unit.ss
+++ b/collects/net/imap-unit.ss
@@ -1,561 +1,556 @@
#lang scheme/unit
- (require scheme/tcp
- "imap-sig.ss"
- "private/rbtree.ss")
+(require scheme/tcp
+ "imap-sig.ss"
+ "private/rbtree.ss")
- (import)
- (export imap^)
+(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)
- (cond [(assoc s flag-names) => cadr] [else 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))))
+(define (skip s n)
+ (subbytes s (if (number? n) n (bytes-length 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 (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 (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))))
+(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)
- (error 'imap-read "failure reading atom: ~a" s)))])])))
+ 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 (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 (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))]))))
- ;; 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
+;; 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 (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 (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 (check-ok reply)
- (unless (and (pair? reply) (tag-eq? (car reply) 'OK))
- (error 'check-ok "server error: ~s" reply)))
+(define (check-ok reply)
+ (unless (and (pair? reply) (tag-eq? (car reply) 'OK))
+ (error 'check-ok "server error: ~s" reply)))
- (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 (ok-tag-eq? i t)
+ (and (tag-eq? (car i) 'OK)
+ ((length i) . >= . 3)
+ (tag-eq? (cadr i) (string->symbol (format "[~a" t)))))
- (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 (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?)
- #:mutable)
- (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 (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 (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 (imap-examine imap inbox)
- (imap-selectish-command imap (list "EXAMINE" inbox) #t))
-
- ;; Used to return (values #f #f) if no change since last check?
- (define (imap-noop imap)
- (imap-selectish-command imap "NOOP" #f))
-
- (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-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-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-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-pending-updates? imap)
- (not (tree-empty? (imap-fetches imap))))
-
- (define (imap-get-expunges imap)
- (let ([l (expunge-tree->list (imap-expunges imap))])
- (set-imap-expunges! imap (new-tree))
- l))
-
- (define (imap-pending-expunges? imap)
- (not (tree-empty? (imap-expunges imap))))
-
- (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 (msg-set msgs)
- (apply
- string-append
- (let loop ([prev #f][msgs msgs])
- (cond
- [(null? msgs) null]
- [(and prev
- (pair? (cdr msgs))
- (= (add1 prev) (car msgs)))
- (loop (car msgs) (cdr msgs))]
- [prev (cons (format ":~a," prev)
- (loop #f msgs))]
- [(null? (cdr msgs)) (list (format "~a" (car msgs)))]
- [(= (add1 (car msgs)) (cadr msgs))
- (cons (format "~a" (car msgs))
- (loop (car msgs) (cdr msgs)))]
- [else (cons (format "~a," (car msgs))
- (loop #f (cdr msgs)))]))))
-
- (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 (msg-set 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 (msg-set 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 (msg-set 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)
+(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
- [(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)))]))
+ [(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-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-struct imap (r w exists recent unseen uidnext uidvalidity
+ expunges fetches new?)
+ #:mutable)
+(define (imap-connection? v) (imap? v))
- (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-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-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 (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 (imap-examine imap inbox)
+ (imap-selectish-command imap (list "EXAMINE" inbox) #t))
+
+;; Used to return (values #f #f) if no change since last check?
+(define (imap-noop imap)
+ (imap-selectish-command imap "NOOP" #f))
+
+(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-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-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-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-pending-updates? imap)
+ (not (tree-empty? (imap-fetches imap))))
+
+(define (imap-get-expunges imap)
+ (let ([l (expunge-tree->list (imap-expunges imap))])
+ (set-imap-expunges! imap (new-tree))
+ l))
+
+(define (imap-pending-expunges? imap)
+ (not (tree-empty? (imap-expunges imap))))
+
+(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 (msg-set msgs)
+ (apply
+ string-append
+ (let loop ([prev #f][msgs msgs])
+ (cond
+ [(null? msgs) null]
+ [(and prev
+ (pair? (cdr msgs))
+ (= (add1 prev) (car msgs)))
+ (loop (car msgs) (cdr msgs))]
+ [prev (cons (format ":~a," prev)
+ (loop #f msgs))]
+ [(null? (cdr msgs)) (list (format "~a" (car msgs)))]
+ [(= (add1 (car msgs)) (cadr msgs))
+ (cons (format "~a" (car msgs))
+ (loop (car msgs) (cdr msgs)))]
+ [else (cons (format "~a," (car msgs))
+ (loop #f (cdr msgs)))]))))
+
+(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 (msg-set 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 (msg-set 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 (msg-set 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/imap.ss b/collects/net/imap.ss
index 8881a8ab49..cf99378297 100644
--- a/collects/net/imap.ss
+++ b/collects/net/imap.ss
@@ -1,49 +1,50 @@
-(module imap mzscheme
- (require mzlib/unit mzlib/contract "imap-sig.ss" "imap-unit.ss")
+#lang scheme/base
+(require scheme/unit scheme/contract "imap-sig.ss" "imap-unit.ss")
- (define-values/invoke-unit/infer imap@)
+(define-values/invoke-unit/infer imap@)
- (provide/contract
- [imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
- [imap-list-child-mailboxes
- (case->
- (imap-connection? (or/c false/c bytes?) . -> . (listof (list/c (listof symbol?) bytes?)))
- (imap-connection? (or/c false/c bytes?) (or/c false/c bytes?)
- . -> .
- (listof (list/c (listof symbol?) bytes?))))])
+(provide/contract
+ [imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
+ [imap-list-child-mailboxes
+ (case->
+ (imap-connection? (or/c false/c bytes?)
+ . -> . (listof (list/c (listof symbol?) bytes?)))
+ (imap-connection? (or/c false/c bytes?) (or/c false/c bytes?)
+ . -> .
+ (listof (list/c (listof symbol?) bytes?))))])
- (provide
- imap-connection?
- imap-connect imap-connect*
- imap-disconnect
- imap-force-disconnect
- imap-reselect
- imap-examine
- imap-noop
- imap-poll
- imap-status
+(provide
+ imap-connection?
+ imap-connect imap-connect*
+ imap-disconnect
+ imap-force-disconnect
+ imap-reselect
+ imap-examine
+ imap-noop
+ imap-poll
+ imap-status
- imap-port-number ; a parameter
+ imap-port-number ; a parameter
- imap-new?
- imap-messages
- imap-recent
- imap-uidnext
- imap-uidvalidity
- imap-unseen
- imap-reset-new!
+ imap-new?
+ imap-messages
+ imap-recent
+ imap-uidnext
+ imap-uidvalidity
+ imap-unseen
+ imap-reset-new!
- imap-get-expunges
- imap-pending-expunges?
- imap-get-updates
- imap-pending-updates?
+ 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-get-messages
+ imap-copy imap-append
+ imap-store imap-flag->symbol symbol->imap-flag
+ imap-expunge
- imap-mailbox-exists?
- imap-create-mailbox
+ imap-mailbox-exists?
+ imap-create-mailbox
- imap-mailbox-flags))
+ imap-mailbox-flags)
diff --git a/collects/net/mime-sig.ss b/collects/net/mime-sig.ss
index ca911b0288..4ef359e4d2 100644
--- a/collects/net/mime-sig.ss
+++ b/collects/net/mime-sig.ss
@@ -12,16 +12,13 @@
;; -- basic mime structures --
(struct message (version entity fields))
-(struct entity
- (type subtype charset encoding
- disposition params id
- description other fields
- parts body))
-(struct disposition
- (type filename creation
- modification read
- size params))
+(struct entity (type subtype charset encoding
+ disposition params id
+ description other fields
+ parts body))
+(struct disposition (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 6fe62d9ae4..032bb50a23 100644
--- a/collects/net/mime-unit.ss
+++ b/collects/net/mime-unit.ss
@@ -29,718 +29,709 @@
#lang scheme/unit
- (require "mime-sig.ss"
- "qp-sig.ss"
- "base64-sig.ss"
- "head-sig.ss"
- "mime-util.ss"
- mzlib/etc
- mzlib/string
- mzlib/port)
+(require "mime-sig.ss"
+ "qp-sig.ss"
+ "base64-sig.ss"
+ "head-sig.ss"
+ "mime-util.ss"
+ scheme/port)
- (import base64^ qp^ head^)
- (export mime^)
+(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 composite-alist
+ '(("message" . message)
+ ("multipart" . multipart)))
- (define mechanism-alist
- '(("7bit" . 7bit)
- ("8bit" . 8bit)
- ("binary" . binary)
- ("quoted-printable" . quoted-printable)
- ("base64" . base64)))
+(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 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)))
- ;; Basic structures
- (define-struct message (version entity fields)
- #:mutable)
- (define-struct entity
- (type subtype charset encoding disposition params id description other
- fields parts body)
- #:mutable)
- (define-struct disposition
- (type filename creation modification read size params)
- #:mutable)
+;; Basic structures
+(define-struct message (version entity fields)
+ #:mutable)
+(define-struct entity
+ (type subtype charset encoding disposition params id description other
+ fields parts body)
+ #:mutable)
+(define-struct disposition
+ (type filename creation modification read size params)
+ #:mutable)
- ;; 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) ())
+;; 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) ())
- ;; *************************************
- ;; Practical stuff, aka MIME in action:
- ;; *************************************
- (define CRLF (format "~a~a" #\return #\newline))
- (define CRLF-binary "=0D=0A") ;; quoted printable representation
+;; *************************************
+;; Practical stuff, aka MIME in action:
+;; *************************************
+(define CRLF (format "~a~a" #\return #\newline))
+(define CRLF-binary "=0D=0A") ;; quoted printable representation
- ;; get-headers : input-port -> string
- ;; returns the header part of a message/part conforming to rfc822, and
- ;; rfc2045.
- (define (get-headers 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)
- (make-disposition
- 'inline ;; type
- "" ;; filename
- #f ;; creation
- #f ;; modification
- #f ;; read
- #f ;; size
- null ;; params
- ))
-
- (define (make-default-entity)
- (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)
- (make-message 1.0 (make-default-entity) null))
-
- (define (mime-decode 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)
- (when (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)))))]
+;; get-headers : input-port -> string
+;; returns the header part of a message/part conforming to rfc822, and
+;; rfc2045.
+(define (get-headers 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
- ;; Unrecognized type, you're on your own! (sorry)
- (mime-decode entity iport)])
- ;; return mime structure
- msg)))
+ ;; 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 (entity-boundary entity)
- (let* ([params (entity-params entity)]
- [ans (assoc "boundary" params)])
- (and ans (cdr ans))))
+(define (make-default-disposition)
+ (make-disposition
+ 'inline ;; type
+ "" ;; filename
+ #f ;; creation
+ #f ;; modification
+ #f ;; read
+ #f ;; size
+ null ;; params
+ ))
- ;; *************************************************
- ;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
- ;; *************************************************
+(define (make-default-entity)
+ (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
+ ))
- ;;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 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))]))))))
+(define (make-default-message)
+ (make-message 1.0 (make-default-entity) null))
- ;; 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 headers)
- (let ([message (make-default-message)])
- (entity-headers headers message #t)
- message))
+(define (mime-decode 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))])))
- ;; 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 headers)
- (let ([message (make-default-message)])
- (entity-headers headers message #f)
- message))
+(define (mime-analyze 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)
+ (when (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))
- ;; entity-headers := [ content CRLF ]
- ;; [ encoding CRLF ]
- ;; [ id CRLF ]
- ;; [ description CRLF ]
- ;; *( MIME-extension-field CRLF )
- (define (entity-headers 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 (entity-boundary entity)
+ (let* ([params (entity-params entity)]
+ [ans (assoc "boundary" params)])
+ (and ans (cdr ans))))
- (define (get-fields 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))))
+;; *************************************************
+;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
+;; *************************************************
- (define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
- (define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
+;;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 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))]))))))
- (define (mime-header? h)
- (or (regexp-match? re:content h)
- (regexp-match? re:mime h)))
+;; 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 headers)
+ (let ([message (make-default-message)])
+ (entity-headers headers message #t)
+ message))
- ;;; 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 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)]))])))))))
+;; 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 headers)
+ (let ([message (make-default-message)])
+ (entity-headers headers message #f)
+ message))
- ;; 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 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))))
+;; entity-headers := [ content CRLF ]
+;; [ encoding CRLF ]
+;; [ id CRLF ]
+;; [ description CRLF ]
+;; *( MIME-extension-field CRLF )
+(define (entity-headers 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)))
- ;; 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 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"))))))
+(define (get-fields 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))))
- ;; description := "Content-Description" ":" *text
- (define re:content-description
- (regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
- (define (description 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"))))))
+(define re:content #rx"^(?i:content-)")
+(define re:mime #rx"^(?i:mime-version):")
- ;; encoding := "Content-Transfer-Encoding" ":" mechanism
- (define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
- (define (encoding 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"))))))
+(define (mime-header? h)
+ (or (regexp-match? re:content h)
+ (regexp-match? re:mime h)))
- ;; id := "Content-ID" ":" msg-id
- (define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
- (define (id 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"))))))
+;;; 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 #rx"^(?i:content-type):([^/]+)/([^/]+)$")
+(define (content 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 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 str)
- (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
- [ans (regexp-match r str)])
- (if ans
- str
- (begin (warning "Invalid msg-id: ~a" str) str))))
+;; From rfc2183 Content-Disposition
+;; disposition := "Content-Disposition" ":"
+;; disposition-type
+;; *(";" disposition-parm)
+(define re:content-disposition #rx"^(?i:content-disposition):(.+)$")
+(define (dispositione 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))))
- ;; mechanism := "7bit" / "8bit" / "binary" /
- ;; "quoted-printable" / "base64" /
- ;; ietf-token / x-token
- (define (mechanism 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)))))
+;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
+(define re:mime-version #rx"^(?i:MIME-Version):([0-9]+)\\.([0-9]+)$")
+(define (version 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"))))))
- ;; MIME-extension-field :=
- ;;
- (define (MIME-extension-field 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")))))))))
+;; description := "Content-Description" ":" *text
+(define re:content-description #rx"^(?i:content-description):[ \t\r\n]*(.*)$")
+(define (description 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"))))))
- ;; type := discrete-type / composite-type
- (define (type value)
- (if (not value)
- (raise (make-empty-type))
- (or (discrete-type value)
- (composite-type value))))
+;; encoding := "Content-Transfer-Encoding" ":" mechanism
+(define re:content-transfer-encoding #rx"^(?i:content-transfer-encoding):(.+)$")
+(define (encoding 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"))))))
- ;; disposition-type := "inline" / "attachment" / extension-token
- (define (disp-type 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)))))
+;; id := "Content-ID" ":" msg-id
+(define re:content-id #rx"^(?i:content-id):(.+)$")
+(define (id 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"))))))
- ;; discrete-type := "text" / "image" / "audio" / "video" /
- ;; "application" / extension-token
- (define (discrete-type value)
- (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
- (if val (cdr val) (extension-token value))))
+;; 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 str)
+ (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
+ [ans (regexp-match r str)])
+ (if ans
+ str
+ (begin (warning "Invalid msg-id: ~a" str) str))))
- ;; composite-type := "message" / "multipart" / extension-token
- (define (composite-type value)
- (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
- (if val (cdr val) (extension-token value))))
+;; mechanism := "7bit" / "8bit" / "binary" /
+;; "quoted-printable" / "base64" /
+;; ietf-token / x-token
+(define (mechanism 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)))))
- ;; extension-token := ietf-token / x-token
- (define (extension-token value)
- (or (ietf-token value)
- (x-token value)))
+;; MIME-extension-field :=
+;;
+(define (MIME-extension-field 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")))))))))
- ;; ietf-token :=
- (define (ietf-token value)
- (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
- (and ans (cdr ans))))
+;; type := discrete-type / composite-type
+(define (type value)
+ (if (not value)
+ (raise (make-empty-type))
+ (or (discrete-type value)
+ (composite-type value))))
- ;; 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]
+;; disposition-type := "inline" / "attachment" / extension-token
+(define (disp-type 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)))))
- ;; x-token :=
- (define (x-token value)
- (let* ([r #rx"^[xX]-(.*)"]
- [h (trim-spaces value)]
- [ans (regexp-match r h)])
- (and ans
- (token (regexp-replace r h "\\1"))
- h)))
+;; discrete-type := "text" / "image" / "audio" / "video" /
+;; "application" / extension-token
+(define (discrete-type value)
+ (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
+ (if val (cdr val) (extension-token value))))
- ;; subtype := extension-token / iana-token
- (define (subtype value)
- (if (not value)
- (raise (make-empty-subtype))
- (or (extension-token value)
- (iana-token value))))
+;; composite-type := "message" / "multipart" / extension-token
+(define (composite-type value)
+ (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
+ (if val (cdr val) (extension-token value))))
- ;; iana-token :=
- (define (iana-token value)
- (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
- (and ans (cdr ans))))
+;; extension-token := ietf-token / x-token
+(define (extension-token value)
+ (or (ietf-token value)
+ (x-token value)))
- ;; parameter := attribute "=" value
- (define re:parameter (regexp "([^=]+)=(.+)"))
- (define (parameter 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))))
+;; ietf-token :=
+(define (ietf-token value)
+ (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
+ (and ans (cdr ans))))
- ;; value := token / quoted-string
- (define (value val)
- (or (token val)
- (quoted-string val)
- val))
+;; 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]
- ;; token := 1*
- ;; tspecials := "(" / ")" / "<" / ">" / "@" /
- ;; "," / ";" / ":" / "\" / <">
- ;; "/" / "[" / "]" / "?" / "="
- ;; ; Must be in quoted-string,
- ;; ; to use within parameter values
- (define (token value)
- (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
- [ans (regexp-match tspecials value)])
- (and ans
- (string=? value (car ans))
- (car ans))))
+;; x-token :=
+(define (x-token value)
+ (let* ([r #rx"^[xX]-(.*)"]
+ [h (trim-spaces value)]
+ [ans (regexp-match r h)])
+ (and ans
+ (token (regexp-replace r h "\\1"))
+ h)))
- ;; attribute := token
- ;; ; Matching of attributes
- ;; ; is ALWAYS case-insensitive.
- (define attribute token)
+;; subtype := extension-token / iana-token
+(define (subtype value)
+ (if (not value)
+ (raise (make-empty-subtype))
+ (or (extension-token value)
+ (iana-token value))))
- (define re:quotes (regexp "\"(.+)\""))
- (define (quoted-string str)
- (let* ([quotes re:quotes]
- [ans (regexp-match quotes str)])
- (and ans (regexp-replace quotes str "\\1"))))
+;; iana-token :=
+(define (iana-token value)
+ (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
+ (and ans (cdr ans))))
- ;; 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 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))))))
+;; parameter := attribute "=" value
+(define re:parameter (regexp "([^=]+)=(.+)"))
+(define (parameter 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))))
- ;; 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))
+;; value := token / quoted-string
+(define (value val)
+ (or (token val)
+ (quoted-string val)
+ val))
- ;; quoted-date-time := quoted-string
- ;; ; contents MUST be an RFC 822 `date-time'
- ;; ; numeric timezones (+HHMM or -HHMM) MUST be used
+;; token := 1*
+;; tspecials := "(" / ")" / "<" / ">" / "@" /
+;; "," / ";" / ":" / "\" / <">
+;; "/" / "[" / "]" / "?" / "="
+;; ; Must be in quoted-string,
+;; ; to use within parameter values
+(define (token value)
+ (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
+ [ans (regexp-match tspecials value)])
+ (and ans
+ (string=? value (car ans))
+ (car ans))))
- (define disp-quoted-data-time date-time)
+;; attribute := token
+;; ; Matching of attributes
+;; ; is ALWAYS case-insensitive.
+(define attribute token)
+
+(define re:quotes (regexp "\"(.+)\""))
+(define (quoted-string 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 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/mime-util.ss b/collects/net/mime-util.ss
index 2bdb219b68..bf5176810c 100644
--- a/collects/net/mime-util.ss
+++ b/collects/net/mime-util.ss
@@ -26,116 +26,111 @@
;;
;; Commentary:
-(module mime-util mzscheme
- (require mzlib/etc)
+#lang scheme/base
- (provide string-tokenizer
- trim-all-spaces
- trim-spaces
- trim-comments
- lowercase
- warning
- cat)
+(provide string-tokenizer
+ trim-all-spaces
+ trim-spaces
+ trim-comments
+ lowercase
+ warning
+ cat)
- ;; string-index returns the leftmost index in string s
- ;; that has character c
- (define (string-index s c)
- (let ([n (string-length s)])
- (let loop ([i 0])
- (cond [(>= i n) #f]
- [(char=? (string-ref s i) c) i]
- [else (loop (+ i 1))]))))
+;; string-index returns the leftmost index in string s
+;; that has character c
+(define (string-index s c)
+ (let ([n (string-length s)])
+ (let loop ([i 0])
+ (cond [(>= i n) #f]
+ [(char=? (string-ref s i) c) i]
+ [else (loop (+ i 1))]))))
- ;; string-tokenizer breaks string s into substrings separated by character c
- (define (string-tokenizer c s)
- (let loop ([s s])
- (if (string=? s "") '()
- (let ([i (string-index s c)])
- (if i (cons (substring s 0 i)
- (loop (substring s (+ i 1)
- (string-length s))))
- (list s))))))
+;; string-tokenizer breaks string s into substrings separated by character c
+(define (string-tokenizer c s)
+ (let loop ([s s])
+ (if (string=? s "") '()
+ (let ([i (string-index s c)])
+ (if i (cons (substring s 0 i)
+ (loop (substring s (+ i 1) (string-length s))))
+ (list s))))))
- ;; Trim all spaces, except those in quoted strings.
- (define re:quote-start (regexp "\""))
- (define re:space (regexp "[ \t\n\r\v]"))
- (define (trim-all-spaces str)
- ;; Break out alternate quoted and unquoted parts.
- ;; Initial and final string are unquoted.
- (let-values ([(unquoted quoted)
- (let loop ([str str] [unquoted null] [quoted null])
- (let ([m (regexp-match-positions re:quote-start str)])
- (if m
- (let ([prefix (substring str 0 (caar m))]
- [rest (substring str (add1 (caar m)) (string-length str))])
- ;; Find closing quote
- (let ([m (regexp-match-positions re:quote-start rest)])
- (if m
- (let ([inside (substring rest 0 (caar m))]
- [rest (substring rest (add1 (caar m)) (string-length rest))])
- (loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
- ;; No closing quote!
- (loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
- (values (reverse (cons str unquoted)) (reverse quoted)))))])
- ;; Put the pieces back together, stripping spaces for unquoted parts:
- (apply
- string-append
- (let loop ([unquoted unquoted][quoted quoted])
- (let ([clean (regexp-replace* re:space (car unquoted) "")])
- (if (null? quoted)
- (list clean)
- (list* clean
- (car quoted)
- (loop (cdr unquoted) (cdr quoted)))))))))
+;; Trim all spaces, except those in quoted strings.
+(define re:quote-start (regexp "\""))
+(define re:space (regexp "[ \t\n\r\v]"))
+(define (trim-all-spaces str)
+ ;; Break out alternate quoted and unquoted parts.
+ ;; Initial and final string are unquoted.
+ (let-values ([(unquoted quoted)
+ (let loop ([str str] [unquoted null] [quoted null])
+ (let ([m (regexp-match-positions re:quote-start str)])
+ (if m
+ (let ([prefix (substring str 0 (caar m))]
+ [rest (substring str (add1 (caar m)) (string-length str))])
+ ;; Find closing quote
+ (let ([m (regexp-match-positions re:quote-start rest)])
+ (if m
+ (let ([inside (substring rest 0 (caar m))]
+ [rest (substring rest (add1 (caar m)) (string-length rest))])
+ (loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
+ ;; No closing quote!
+ (loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
+ (values (reverse (cons str unquoted)) (reverse quoted)))))])
+ ;; Put the pieces back together, stripping spaces for unquoted parts:
+ (apply
+ string-append
+ (let loop ([unquoted unquoted][quoted quoted])
+ (let ([clean (regexp-replace* re:space (car unquoted) "")])
+ (if (null? quoted)
+ (list clean)
+ (list* clean
+ (car quoted)
+ (loop (cdr unquoted) (cdr quoted)))))))))
- ;; Only trims left and right spaces:
- (define (trim-spaces str)
- (trim-right (trim-left str)))
+;; Only trims left and right spaces:
+(define (trim-spaces str)
+ (trim-right (trim-left str)))
- (define re:left-spaces (regexp "^[ \t\r\n\v]+"))
- (define (trim-left str)
- (regexp-replace re:left-spaces str ""))
+(define re:left-spaces (regexp "^[ \t\r\n\v]+"))
+(define (trim-left str)
+ (regexp-replace re:left-spaces str ""))
- (define re:right-spaces (regexp "[ \t\r\n\v]+$"))
- (define (trim-right str)
- (regexp-replace re:right-spaces str ""))
+(define re:right-spaces (regexp "[ \t\r\n\v]+$"))
+(define (trim-right str)
+ (regexp-replace re:right-spaces str ""))
- (define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
- (define (trim-comments str)
- (let ([positions (regexp-match-positions re:comments str)])
- (if positions
- (string-append (substring str 0 (caaddr positions))
- (substring str (cdaddr positions) (string-length str)))
- str)))
+(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
+(define (trim-comments str)
+ (let ([positions (regexp-match-positions re:comments str)])
+ (if positions
+ (string-append (substring str 0 (caaddr positions))
+ (substring str (cdaddr positions) (string-length str)))
+ str)))
- (define (lowercase str)
- (let loop ([out ""] [rest str] [size (string-length str)])
- (cond [(zero? size) out]
- [else
- (loop (string-append out (string
- (char-downcase
- (string-ref rest 0))))
- (substring rest 1 size)
- (sub1 size))])))
-
- (define warning
- void
- #;
- (lambda (msg . args)
- (fprintf (current-error-port)
- (apply format (cons msg args)))
- (newline (current-error-port)))
- )
-
- ;; Copies its input `in' to its ouput port if given, it uses
- ;; current-output-port if out is not provided.
- (define cat
- (opt-lambda (in (out (current-output-port)))
- (let loop ([ln (read-line in)])
- (unless (eof-object? ln)
- (fprintf out "~a\n" ln)
- (loop (read-line in))))))
+(define (lowercase str)
+ (let loop ([out ""] [rest str] [size (string-length str)])
+ (cond [(zero? size) out]
+ [else
+ (loop (string-append out (string
+ (char-downcase
+ (string-ref rest 0))))
+ (substring rest 1 size)
+ (sub1 size))])))
+(define warning
+ void
+ #;
+ (lambda (msg . args)
+ (fprintf (current-error-port)
+ (apply format (cons msg args)))
+ (newline (current-error-port)))
)
+;; Copies its input `in' to its ouput port if given, it uses
+;; current-output-port if out is not provided.
+(define (cat in [out (current-output-port)])
+ (let loop ([ln (read-line in)])
+ (unless (eof-object? ln)
+ (fprintf out "~a\n" ln)
+ (loop (read-line in)))))
+
;;; mime-util.ss ends here
diff --git a/collects/net/mime.ss b/collects/net/mime.ss
index 68a75cbdc5..43a6213c11 100644
--- a/collects/net/mime.ss
+++ b/collects/net/mime.ss
@@ -26,26 +26,26 @@
;;
;; Commentary:
-(module mime mzscheme
- (require mzlib/unit
- "mime-sig.ss"
- "mime-unit.ss"
- "qp-sig.ss"
- "qp.ss"
- "base64-sig.ss"
- "base64.ss"
- "head-sig.ss"
- "head.ss")
+#lang scheme/base
+(require scheme/unit
+ "mime-sig.ss"
+ "mime-unit.ss"
+ "qp-sig.ss"
+ "qp.ss"
+ "base64-sig.ss"
+ "base64.ss"
+ "head-sig.ss"
+ "head.ss")
- (define-unit-from-context base64@ base64^)
- (define-unit-from-context qp@ qp^)
- (define-unit-from-context head@ head^)
+(define-unit-from-context base64@ base64^)
+(define-unit-from-context qp@ qp^)
+(define-unit-from-context head@ head^)
- (define-compound-unit/infer mime@2 (import) (export mime^)
- (link base64@ qp@ head@ mime@))
+(define-compound-unit/infer mime@2 (import) (export mime^)
+ (link base64@ qp@ head@ mime@))
- (define-values/invoke-unit/infer mime@2)
+(define-values/invoke-unit/infer mime@2)
- (provide-signature-elements mime^))
+(provide-signature-elements mime^)
;;; mime.ss ends here
diff --git a/collects/net/nntp.ss b/collects/net/nntp.ss
index 7162cc0cc4..015ebfc49f 100644
--- a/collects/net/nntp.ss
+++ b/collects/net/nntp.ss
@@ -1,6 +1,6 @@
-(module nntp mzscheme
- (require mzlib/unit "nntp-sig.ss" "nntp-unit.ss")
+#lang scheme/base
+(require scheme/unit "nntp-sig.ss" "nntp-unit.ss")
- (define-values/invoke-unit/infer nntp@)
+(define-values/invoke-unit/infer nntp@)
- (provide-signature-elements nntp^))
+(provide-signature-elements nntp^)
diff --git a/collects/net/pop3.ss b/collects/net/pop3.ss
index e327b256a3..a303c61150 100644
--- a/collects/net/pop3.ss
+++ b/collects/net/pop3.ss
@@ -1,9 +1,9 @@
-(module pop3 mzscheme
- (require mzlib/unit "pop3-sig.ss" "pop3-unit.ss")
+#lang scheme/base
+(require scheme/unit "pop3-sig.ss" "pop3-unit.ss")
- (define-values/invoke-unit/infer pop3@)
+(define-values/invoke-unit/infer pop3@)
- (provide-signature-elements pop3^))
+(provide-signature-elements pop3^)
#|
diff --git a/collects/net/qp-unit.ss b/collects/net/qp-unit.ss
index fdacd4a8a0..b824619512 100644
--- a/collects/net/qp-unit.ss
+++ b/collects/net/qp-unit.ss
@@ -28,148 +28,138 @@
#lang scheme/unit
- (require "qp-sig.ss"
- mzlib/etc)
+(require "qp-sig.ss")
- (import)
- (export qp^)
+(import)
+(export qp^)
- ;; Exceptions:
- ;; String or input-port expected:
- (define-struct qp-error ())
- (define-struct (qp-wrong-input qp-error) ())
- (define-struct (qp-wrong-line-size qp-error) (size))
+;; Exceptions:
+;; String or input-port expected:
+(define-struct qp-error ())
+(define-struct (qp-wrong-input qp-error) ())
+(define-struct (qp-wrong-line-size qp-error) (size))
- ;; qp-encode : bytes -> bytes
- ;; returns the quoted printable representation of STR.
- (define qp-encode
- (lambda (str)
- (let ([out (open-output-bytes)])
- (qp-encode-stream (open-input-bytes str) out #"\r\n")
- (get-output-bytes out))))
+;; qp-encode : bytes -> bytes
+;; returns the quoted printable representation of STR.
+(define (qp-encode str)
+ (let ([out (open-output-bytes)])
+ (qp-encode-stream (open-input-bytes str) out #"\r\n")
+ (get-output-bytes out)))
- ;; qp-decode : string -> string
- ;; returns STR unqp.
- (define qp-decode
- (lambda (str)
- (let ([out (open-output-bytes)])
- (qp-decode-stream (open-input-bytes str) out)
- (get-output-bytes out))))
+;; qp-decode : string -> string
+;; returns STR unqp.
+(define (qp-decode str)
+ (let ([out (open-output-bytes)])
+ (qp-decode-stream (open-input-bytes str) out)
+ (get-output-bytes out)))
- (define qp-decode-stream
- (lambda (in out)
- (let loop ([ch (read-byte in)])
- (unless (eof-object? ch)
- (case ch
- [(61) ;; A "=", which is quoted-printable stuff
- (let ([next (read-byte in)])
- (cond
- [(eq? next 10)
- ;; Soft-newline -- drop it
- (void)]
- [(eq? next 13)
- ;; Expect a newline for a soft CRLF...
- (let ([next-next (read-byte in)])
- (if (eq? next-next 10)
- ;; Good.
- (loop (read-byte in))
- ;; Not a LF? Well, ok.
- (loop next-next)))]
- [(hex-digit? next)
- (let ([next-next (read-byte in)])
- (cond [(eof-object? next-next)
- (warning "Illegal qp sequence: `=~a'" next)
- (display "=" out)
- (display next out)]
- [(hex-digit? next-next)
- ;; qp-encoded
- (write-byte (hex-bytes->byte next next-next)
- out)]
- [else
- (warning "Illegal qp sequence: `=~a~a'" next next-next)
- (write-byte 61 out)
- (write-byte next out)
- (write-byte next-next out)]))]
- [else
- ;; Warning: invalid
- (warning "Illegal qp sequence: `=~a'" next)
- (write-byte 61 out)
- (write-byte next out)])
- (loop (read-byte in)))]
- [else
- (write-byte ch out)
- (loop (read-byte in))])))))
+(define (qp-decode-stream in out)
+ (let loop ([ch (read-byte in)])
+ (unless (eof-object? ch)
+ (case ch
+ [(61) ;; A "=", which is quoted-printable stuff
+ (let ([next (read-byte in)])
+ (cond
+ [(eq? next 10)
+ ;; Soft-newline -- drop it
+ (void)]
+ [(eq? next 13)
+ ;; Expect a newline for a soft CRLF...
+ (let ([next-next (read-byte in)])
+ (if (eq? next-next 10)
+ ;; Good.
+ (loop (read-byte in))
+ ;; Not a LF? Well, ok.
+ (loop next-next)))]
+ [(hex-digit? next)
+ (let ([next-next (read-byte in)])
+ (cond [(eof-object? next-next)
+ (warning "Illegal qp sequence: `=~a'" next)
+ (display "=" out)
+ (display next out)]
+ [(hex-digit? next-next)
+ ;; qp-encoded
+ (write-byte (hex-bytes->byte next next-next)
+ out)]
+ [else
+ (warning "Illegal qp sequence: `=~a~a'" next next-next)
+ (write-byte 61 out)
+ (write-byte next out)
+ (write-byte next-next out)]))]
+ [else
+ ;; Warning: invalid
+ (warning "Illegal qp sequence: `=~a'" next)
+ (write-byte 61 out)
+ (write-byte next out)])
+ (loop (read-byte in)))]
+ [else
+ (write-byte ch out)
+ (loop (read-byte in))]))))
- (define warning
- (lambda (msg . args)
- (when #f
- (fprintf (current-error-port)
- (apply format msg args))
- (newline (current-error-port)))))
+(define (warning msg . args)
+ (when #f
+ (fprintf (current-error-port)
+ (apply format msg args))
+ (newline (current-error-port))))
- (define (hex-digit? i)
- (vector-ref hex-values i))
+(define (hex-digit? i)
+ (vector-ref hex-values i))
- (define hex-bytes->byte
- (lambda (b1 b2)
- (+ (* 16 (vector-ref hex-values b1))
- (vector-ref hex-values b2))))
+(define (hex-bytes->byte b1 b2)
+ (+ (* 16 (vector-ref hex-values b1))
+ (vector-ref hex-values b2)))
- (define write-hex-bytes
- (lambda (byte p)
- (write-byte 61 p)
- (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p)
- (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)))
+(define (write-hex-bytes 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 in out [newline-string #"\n"])
+ (let loop ([col 0])
+ (if (= col 75)
+ (begin
+ ;; Soft newline:
+ (write-byte 61 out)
+ (display newline-string out)
+ (loop 0))
+ (let ([i (read-byte in)])
+ (cond
+ [(eof-object? i) (void)]
+ [(or (= i 10) (= i 13))
+ (write-byte i out)
+ (loop 0)]
+ [(or (<= 33 i 60) (<= 62 i 126)
+ (and (or (= i 32) (= i 9))
+ (not (let ([next (peek-byte in)])
+ (or (eof-object? next) (= next 10) (= next 13))))))
+ ;; single-byte mode:
+ (write-byte i out)
+ (loop (add1 col))]
+ [(>= col 73)
+ ;; need a soft newline first
+ (write-byte 61 out)
+ (display newline-string out)
+ ;; now the octect
+ (write-hex-bytes i out)
+ (loop 3)]
+ [else
+ ;; an octect
+ (write-hex-bytes i out)
+ (loop (+ col 3))])))))
- (define qp-encode-stream
- (opt-lambda (in out [newline-string #"\n"])
- (let loop ([col 0])
- (if (= col 75)
- (begin
- ;; Soft newline:
- (write-byte 61 out)
- (display newline-string out)
- (loop 0))
- (let ([i (read-byte in)])
- (cond
- [(eof-object? i) (void)]
- [(or (= i 10) (= i 13))
- (write-byte i out)
- (loop 0)]
- [(or (<= 33 i 60) (<= 62 i 126)
- (and (or (= i 32) (= i 9))
- (not (let ([next (peek-byte in)])
- (or (eof-object? next) (= next 10) (= next 13))))))
- ;; single-byte mode:
- (write-byte i out)
- (loop (add1 col))]
- [(>= col 73)
- ;; need a soft newline first
- (write-byte 61 out)
- (display newline-string out)
- ;; now the octect
- (write-hex-bytes i out)
- (loop 3)]
- [else
- ;; an octect
- (write-hex-bytes i out)
- (loop (+ col 3))]))))))
-
- ;; Tables
- (define hex-values (make-vector 256 #f))
- (define hex-bytes (make-vector 16))
- (let loop ([i 0])
- (unless (= i 10)
- (vector-set! hex-values (+ i 48) i)
- (vector-set! hex-bytes i (+ i 48))
- (loop (add1 i))))
- (let loop ([i 0])
- (unless (= i 6)
- (vector-set! hex-values (+ i 65) (+ 10 i))
- (vector-set! hex-values (+ i 97) (+ 10 i))
- (vector-set! hex-bytes (+ 10 i) (+ i 65))
- (loop (add1 i))))
+;; Tables
+(define hex-values (make-vector 256 #f))
+(define hex-bytes (make-vector 16))
+(let loop ([i 0])
+ (unless (= i 10)
+ (vector-set! hex-values (+ i 48) i)
+ (vector-set! hex-bytes i (+ i 48))
+ (loop (add1 i))))
+(let loop ([i 0])
+ (unless (= i 6)
+ (vector-set! hex-values (+ i 65) (+ 10 i))
+ (vector-set! hex-values (+ i 97) (+ 10 i))
+ (vector-set! hex-bytes (+ 10 i) (+ i 65))
+ (loop (add1 i))))
;;; qp-unit.ss ends here
diff --git a/collects/net/qp.ss b/collects/net/qp.ss
index 346aef1b94..8dd2bc6fcb 100644
--- a/collects/net/qp.ss
+++ b/collects/net/qp.ss
@@ -26,11 +26,11 @@
;;
;; Commentary:
-(module qp mzscheme
- (require mzlib/unit "qp-sig.ss" "qp-unit.ss")
+#lang scheme/base
+(require mzlib/unit "qp-sig.ss" "qp-unit.ss")
- (define-values/invoke-unit/infer qp@)
+(define-values/invoke-unit/infer qp@)
- (provide-signature-elements qp^))
+(provide-signature-elements qp^)
;;; qp.ss ends here
diff --git a/collects/net/sendmail-unit.ss b/collects/net/sendmail-unit.ss
index e01ff9a400..eefe4a254e 100644
--- a/collects/net/sendmail-unit.ss
+++ b/collects/net/sendmail-unit.ss
@@ -1,119 +1,119 @@
#lang scheme/unit
- (require mzlib/process "sendmail-sig.ss")
+(require mzlib/process "sendmail-sig.ss")
- (import)
- (export sendmail^)
+(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
+ 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
+ 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/sendmail.ss b/collects/net/sendmail.ss
index 19387b7a98..0b30111519 100644
--- a/collects/net/sendmail.ss
+++ b/collects/net/sendmail.ss
@@ -1,6 +1,6 @@
-(module sendmail mzscheme
- (require mzlib/unit "sendmail-sig.ss" "sendmail-unit.ss")
+#lang scheme/base
+(require scheme/unit "sendmail-sig.ss" "sendmail-unit.ss")
- (define-values/invoke-unit/infer sendmail@)
+(define-values/invoke-unit/infer sendmail@)
- (provide-signature-elements sendmail^))
+(provide-signature-elements sendmail^)
diff --git a/collects/net/smtp.ss b/collects/net/smtp.ss
index 8aa43caa13..8f97721449 100644
--- a/collects/net/smtp.ss
+++ b/collects/net/smtp.ss
@@ -1,6 +1,6 @@
-(module smtp mzscheme
- (require mzlib/unit "smtp-sig.ss" "smtp-unit.ss")
+#lang scheme/base
+(require scheme/unit "smtp-sig.ss" "smtp-unit.ss")
- (define-values/invoke-unit/infer smtp@)
+(define-values/invoke-unit/infer smtp@)
- (provide-signature-elements smtp^))
+(provide-signature-elements smtp^)
diff --git a/collects/net/ssl-tcp-unit.ss b/collects/net/ssl-tcp-unit.ss
index bd31d15d15..175128433a 100644
--- a/collects/net/ssl-tcp-unit.ss
+++ b/collects/net/ssl-tcp-unit.ss
@@ -1,63 +1,59 @@
-(module ssl-tcp-unit mzscheme
- (provide make-ssl-tcp@)
- (require mzlib/unit
- "tcp-sig.ss"
- (lib "mzssl.ss" "openssl")
- mzlib/etc)
+#lang scheme/base
+(provide make-ssl-tcp@)
+(require scheme/unit
+ "tcp-sig.ss"
+ openssl/mzssl)
- (define (make-ssl-tcp@
- server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
- client-cert-file client-key-file client-root-cert-files)
- (unit
- (import)
- (export tcp^)
+(define (make-ssl-tcp@
+ server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
+ client-cert-file client-key-file client-root-cert-files)
+ (unit
+ (import)
+ (export tcp^)
- (define ctx (ssl-make-client-context))
- (when client-cert-file
- (ssl-load-certificate-chain! ctx client-cert-file))
- (when client-key-file
- (ssl-load-private-key! ctx client-key-file))
- (when client-root-cert-files
- (ssl-set-verify! ctx #t)
- (map (lambda (f)
- (ssl-load-verify-root-certificates! ctx f))
- client-root-cert-files))
+ (define ctx (ssl-make-client-context))
+ (when client-cert-file
+ (ssl-load-certificate-chain! ctx client-cert-file))
+ (when client-key-file
+ (ssl-load-private-key! ctx client-key-file))
+ (when client-root-cert-files
+ (ssl-set-verify! ctx #t)
+ (map (lambda (f)
+ (ssl-load-verify-root-certificates! ctx f))
+ client-root-cert-files))
- (define (tcp-abandon-port p)
- (if (input-port? p)
- (close-input-port p)
- (close-output-port p)))
+ (define (tcp-abandon-port p)
+ (if (input-port? p)
+ (close-input-port p)
+ (close-output-port p)))
- (define tcp-accept ssl-accept)
- (define tcp-accept/enable-break ssl-accept/enable-break)
+ (define tcp-accept ssl-accept)
+ (define tcp-accept/enable-break ssl-accept/enable-break)
- ;; accept-ready? doesn't really work for SSL:
- (define (tcp-accept-ready? p)
- #f)
+ ;; accept-ready? doesn't really work for SSL:
+ (define (tcp-accept-ready? p)
+ #f)
- (define tcp-addresses ssl-addresses)
- (define tcp-close ssl-close)
- (define tcp-connect
- (opt-lambda (hostname port-k)
- (ssl-connect hostname port-k ctx)))
- (define tcp-connect/enable-break
- (opt-lambda (hostname port-k)
- (ssl-connect/enable-break hostname port-k ctx)))
+ (define tcp-addresses ssl-addresses)
+ (define tcp-close ssl-close)
+ (define (tcp-connect hostname port-k)
+ (ssl-connect hostname port-k ctx))
+ (define (tcp-connect/enable-break hostname port-k)
+ (ssl-connect/enable-break hostname port-k ctx))
- (define tcp-listen
- (opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
- (let ([l (ssl-listen port allow-k reuse? hostname)])
- (when server-cert-file
- (ssl-load-certificate-chain! l server-cert-file))
- (when server-key-file
- (ssl-load-private-key! l server-key-file))
- (when server-root-cert-files
- (ssl-set-verify! l #t)
- (map (lambda (f)
- (ssl-load-verify-root-certificates! l f))
- server-root-cert-files))
- (when server-suggest-auth-file
- (ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
- l)))
+ (define (tcp-listen port [allow-k 4] [reuse? #f] [hostname #f])
+ (let ([l (ssl-listen port allow-k reuse? hostname)])
+ (when server-cert-file
+ (ssl-load-certificate-chain! l server-cert-file))
+ (when server-key-file
+ (ssl-load-private-key! l server-key-file))
+ (when server-root-cert-files
+ (ssl-set-verify! l #t)
+ (map (lambda (f)
+ (ssl-load-verify-root-certificates! l f))
+ server-root-cert-files))
+ (when server-suggest-auth-file
+ (ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
+ l))
- (define tcp-listener? ssl-listener?))))
+ (define tcp-listener? ssl-listener?)))
diff --git a/collects/net/tcp-redirect.ss b/collects/net/tcp-redirect.ss
index eb7327f03c..8f9c0635a3 100644
--- a/collects/net/tcp-redirect.ss
+++ b/collects/net/tcp-redirect.ss
@@ -1,138 +1,133 @@
-(module tcp-redirect mzscheme
- (provide tcp-redirect)
+#lang scheme/base
+(provide tcp-redirect)
- (require mzlib/unit
- mzlib/async-channel
- mzlib/etc
- "tcp-sig.ss")
+(require scheme/unit
+ scheme/tcp
+ scheme/async-channel
+ "tcp-sig.ss")
- (define raw:tcp-abandon-port tcp-abandon-port)
- (define raw:tcp-accept tcp-accept)
- (define raw:tcp-accept/enable-break tcp-accept/enable-break)
- (define raw:tcp-accept-ready? tcp-accept-ready?)
- (define raw:tcp-addresses tcp-addresses)
- (define raw:tcp-close tcp-close)
- (define raw:tcp-connect tcp-connect)
- (define raw:tcp-connect/enable-break tcp-connect/enable-break)
- (define raw:tcp-listen tcp-listen)
- (define raw:tcp-listener? tcp-listener?)
+(define raw:tcp-abandon-port tcp-abandon-port)
+(define raw:tcp-accept tcp-accept)
+(define raw:tcp-accept/enable-break tcp-accept/enable-break)
+(define raw:tcp-accept-ready? tcp-accept-ready?)
+(define raw:tcp-addresses tcp-addresses)
+(define raw:tcp-close tcp-close)
+(define raw:tcp-connect tcp-connect)
+(define raw:tcp-connect/enable-break tcp-connect/enable-break)
+(define raw:tcp-listen tcp-listen)
+(define raw:tcp-listener? tcp-listener?)
- ; For tcp-listeners, we use an else branch in the conds since
- ; (instead of a contract) I want the same error message as the raw
- ; primitive for bad inputs.
+;; For tcp-listeners, we use an else branch in the conds since
+;; (instead of a contract) I want the same error message as the raw
+;; primitive for bad inputs.
- ; : (listof nat) -> (unit/sig () -> net:tcp^)
- (define tcp-redirect
- (opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
- (unit
- (import)
- (export tcp^)
- ; : (make-pipe-listener nat (channel (cons iport oport)))
- (define-struct pipe-listener (port channel))
+;; : (listof nat) -> (unit/sig () -> net:tcp^)
+(define (tcp-redirect redirected-ports [redirected-address "127.0.0.1"])
+ (unit
+ (import)
+ (export tcp^)
+ ;; : (make-pipe-listener nat (channel (cons iport oport)))
+ (define-struct pipe-listener (port channel))
- ; : port -> void
- (define (tcp-abandon-port tcp-port)
- (when (tcp-port? tcp-port)
- (raw:tcp-abandon-port tcp-port)))
+ ;; : port -> void
+ (define (tcp-abandon-port tcp-port)
+ (when (tcp-port? tcp-port)
+ (raw:tcp-abandon-port tcp-port)))
- ; : listener -> iport oport
- (define (tcp-accept tcp-listener)
- (cond
- [(pipe-listener? tcp-listener)
- (let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
- (values (car in-out) (cdr in-out)))]
- [else (raw:tcp-accept tcp-listener)]))
+ ;; : listener -> iport oport
+ (define (tcp-accept tcp-listener)
+ (cond
+ [(pipe-listener? tcp-listener)
+ (let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
+ (values (car in-out) (cdr in-out)))]
+ [else (raw:tcp-accept tcp-listener)]))
- ; : listener -> iport oport
- (define (tcp-accept/enable-break tcp-listener)
- (cond
- [(pipe-listener? tcp-listener)
- ; XXX put this into async-channel.ss as async-channel-get/enable-break
- (sync/enable-break
- (handle-evt
- (pipe-listener-channel tcp-listener)
- (lambda (in-out)
- (values (car in-out) (cdr in-out)))))]
- #;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
- (values (car in-out) (cdr in-out)))
- [else (raw:tcp-accept/enable-break tcp-listener)]))
+ ;; : listener -> iport oport
+ (define (tcp-accept/enable-break tcp-listener)
+ (cond
+ [(pipe-listener? tcp-listener)
+ ;; XXX put this into async-channel.ss as async-channel-get/enable-break
+ (sync/enable-break
+ (handle-evt
+ (pipe-listener-channel tcp-listener)
+ (lambda (in-out)
+ (values (car in-out) (cdr in-out)))))]
+ #;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
+ (values (car in-out) (cdr in-out)))
+ [else (raw:tcp-accept/enable-break tcp-listener)]))
- ; : tcp-listener -> iport oport
- ; FIX - check channel queue size
- (define (tcp-accept-ready? tcp-listener)
- (cond
- [(pipe-listener? tcp-listener) #t]
- [else (raw:tcp-accept-ready? tcp-listener)]))
+ ;; : tcp-listener -> iport oport
+ ;; FIX - check channel queue size
+ (define (tcp-accept-ready? tcp-listener)
+ (cond
+ [(pipe-listener? tcp-listener) #t]
+ [else (raw:tcp-accept-ready? tcp-listener)]))
- ; : tcp-port -> str str
- (define (tcp-addresses tcp-port)
- (if (tcp-port? tcp-port)
- (raw:tcp-addresses tcp-port)
- (values redirected-address redirected-address)))
+ ;; : tcp-port -> str str
+ (define (tcp-addresses tcp-port)
+ (if (tcp-port? tcp-port)
+ (raw:tcp-addresses tcp-port)
+ (values redirected-address redirected-address)))
- ; : port -> void
- (define (tcp-close tcp-listener)
- (if (tcp-listener? tcp-listener)
- (raw:tcp-close tcp-listener)
- (hash-table-remove!
- port-table
- (pipe-listener-port tcp-listener))))
+ ;; : port -> void
+ (define (tcp-close tcp-listener)
+ (if (tcp-listener? tcp-listener)
+ (raw:tcp-close tcp-listener)
+ (hash-remove! port-table (pipe-listener-port tcp-listener))))
- ; : (str nat -> iport oport) -> str nat -> iport oport
- (define (gen-tcp-connect raw)
- (lambda (hostname-string port)
- (if (and (string=? redirected-address hostname-string)
- (redirect? port))
- (let-values ([(to-in from-out) (make-pipe)]
- [(from-in to-out) (make-pipe)])
- (async-channel-put
- (pipe-listener-channel
- (hash-table-get
- port-table
- port
- (lambda ()
- (raise (make-exn:fail:network
- (format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
- hostname-string port)
- (current-continuation-marks))))))
- (cons to-in to-out))
- (values from-in from-out))
- (raw hostname-string port))))
+ ;; : (str nat -> iport oport) -> str nat -> iport oport
+ (define (gen-tcp-connect raw)
+ (lambda (hostname-string port)
+ (if (and (string=? redirected-address hostname-string)
+ (redirect? port))
+ (let-values ([(to-in from-out) (make-pipe)]
+ [(from-in to-out) (make-pipe)])
+ (async-channel-put
+ (pipe-listener-channel
+ (hash-ref port-table port
+ (lambda ()
+ (raise (make-exn:fail:network
+ (format "tcp-connect: connection to ~a, port ~a failed (nobody is listening)"
+ hostname-string port)
+ (current-continuation-marks))))))
+ (cons to-in to-out))
+ (values from-in from-out))
+ (raw hostname-string port))))
- ; : str nat -> iport oport
- (define tcp-connect (gen-tcp-connect raw:tcp-connect))
+ ;; : str nat -> iport oport
+ (define tcp-connect (gen-tcp-connect raw:tcp-connect))
- ; : str nat -> iport oport
- (define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
+ ;; : str nat -> iport oport
+ (define tcp-connect/enable-break
+ (gen-tcp-connect raw:tcp-connect/enable-break))
- ; FIX - support the reuse? flag.
- (define tcp-listen
- (opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
- (hash-table-get
- port-table
- port
- (lambda ()
- (if (redirect? port)
- (let ([listener (make-pipe-listener port (make-async-channel))])
- (hash-table-put! port-table port listener)
- listener)
- (raw:tcp-listen port max-allow-wait reuse? hostname-string))))))
+ ;; FIX - support the reuse? flag.
+ (define (tcp-listen port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
+ (hash-ref port-table port
+ (lambda ()
+ (if (redirect? port)
+ (let ([listener (make-pipe-listener port (make-async-channel))])
+ (hash-set! port-table port listener)
+ listener)
+ (raw:tcp-listen port max-allow-wait reuse? hostname-string)))))
- ; : tst -> bool
- (define (tcp-listener? x)
- (or (pipe-listener? x) (raw:tcp-listener? x)))
+ ;; : tst -> bool
+ (define (tcp-listener? x)
+ (or (pipe-listener? x) (raw:tcp-listener? x)))
- ; ---------- private ----------
+ ;; ---------- private ----------
- ; : (hash-table nat[port] -> tcp-listener)
- (define port-table (make-hash-table))
+ ;; : (hash nat[port] -> tcp-listener)
+ (define port-table (make-hasheq))
- (define redirect-table
- (let ([table (make-hash-table)])
- (for-each (lambda (x) (hash-table-put! table x #t))
- redirected-ports)
- table))
+ (define redirect-table
+ (let ([table (make-hasheq)])
+ (for-each (lambda (x) (hash-set! table x #t))
+ redirected-ports)
+ table))
- ; : nat -> bool
- (define (redirect? port)
- (hash-table-get redirect-table port (lambda () #f)))))))
+ ;; : nat -> bool
+ (define (redirect? port)
+ (hash-ref redirect-table port #f))
+
+ ))
diff --git a/collects/net/tcp-unit.ss b/collects/net/tcp-unit.ss
index de87f4f8cb..0ba7d9e503 100644
--- a/collects/net/tcp-unit.ss
+++ b/collects/net/tcp-unit.ss
@@ -1,6 +1,6 @@
-(module tcp-unit mzscheme
- (provide tcp@)
+#lang scheme/base
+(provide tcp@)
- (require mzlib/unit "tcp-sig.ss")
+(require scheme/unit scheme/tcp "tcp-sig.ss")
- (define-unit-from-context tcp@ tcp^))
+(define-unit-from-context tcp@ tcp^)
diff --git a/collects/net/unihead.ss b/collects/net/unihead.ss
index 581e295a36..fb922a2e25 100644
--- a/collects/net/unihead.ss
+++ b/collects/net/unihead.ss
@@ -1,118 +1,118 @@
-(module unihead mzscheme
- (require net/base64
- net/qp
- mzlib/string)
+#lang mzscheme
+(require net/base64
+ net/qp
+ mzlib/string)
- (provide encode-for-header
- decode-for-header
- generalize-encoding)
+(provide encode-for-header
+ decode-for-header
+ generalize-encoding)
- (define re:ascii #rx"^[\u0-\u7F]*$")
+(define re:ascii #rx"^[\u0-\u7F]*$")
- (define (encode-for-header s)
- (if (regexp-match? re:ascii s)
- s
- (let ([l (regexp-split #rx"\r\n" s)])
- (apply string-append
- (map encode-line-for-header l)))))
+(define (encode-for-header s)
+ (if (regexp-match? re:ascii s)
+ s
+ (let ([l (regexp-split #rx"\r\n" s)])
+ (apply string-append
+ (map encode-line-for-header l)))))
- (define (encode-line-for-header s)
- (define (loop s string->bytes charset encode encoding)
- ;; Find ASCII (and no "=") prefix before a space
- (let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
- (if m
- (string-append
- (cadr m)
- (loop (caddr m) string->bytes charset encode encoding))
- ;; Find ASCII (and no "=") suffix after a space
- (let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
- (if m
- (string-append
- (loop (cadr m) string->bytes charset encode encoding)
- (caddr m))
- (format "=?~a?~a?~a?="
- charset encoding
- (regexp-replace* #rx#"[\r\n]+$"
- (encode (string->bytes s))
- #"")))))))
- (cond
- [(regexp-match? re:ascii s)
- ;; ASCII - do nothing
- s]
- [(regexp-match? #rx"[^\u0-\uFF]" s)
- ;; Not Latin-1, so use UTF-8
- (loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
- [else
- ;; use Latin-1
- (loop s string->bytes/latin-1 "ISO-8859-1"
- (lambda (s)
- (regexp-replace #rx#" " (qp-encode s) #"_"))
- "Q")]))
+(define (encode-line-for-header s)
+ (define (loop s string->bytes charset encode encoding)
+ ;; Find ASCII (and no "=") prefix before a space
+ (let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
+ (if m
+ (string-append
+ (cadr m)
+ (loop (caddr m) string->bytes charset encode encoding))
+ ;; Find ASCII (and no "=") suffix after a space
+ (let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
+ (if m
+ (string-append
+ (loop (cadr m) string->bytes charset encode encoding)
+ (caddr m))
+ (format "=?~a?~a?~a?="
+ charset encoding
+ (regexp-replace* #rx#"[\r\n]+$"
+ (encode (string->bytes s))
+ #"")))))))
+ (cond
+ [(regexp-match? re:ascii s)
+ ;; ASCII - do nothing
+ s]
+ [(regexp-match? #rx"[^\u0-\uFF]" s)
+ ;; Not Latin-1, so use UTF-8
+ (loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
+ [else
+ ;; use Latin-1
+ (loop s string->bytes/latin-1 "ISO-8859-1"
+ (lambda (s)
+ (regexp-replace #rx#" " (qp-encode s) #"_"))
+ "Q")]))
- ;; ----------------------------------------
+;; ----------------------------------------
- (define re:us-ascii #rx#"^(?i:us-ascii)$")
- (define re:iso #rx#"^(?i:iso-8859-1)$")
- (define re:gb #rx#"^(?i:gb(?:2312)?)$")
- (define re:ks_c #rx#"^(?i:ks_c_5601-1987)$")
- (define re:utf-8 #rx#"^(?i:utf-8)$")
+(define re:us-ascii #rx#"^(?i:us-ascii)$")
+(define re:iso #rx#"^(?i:iso-8859-1)$")
+(define re:gb #rx#"^(?i:gb(?:2312)?)$")
+(define re:ks_c #rx#"^(?i:ks_c_5601-1987)$")
+(define re:utf-8 #rx#"^(?i:utf-8)$")
- (define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$")
+(define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$")
- (define (generalize-encoding encoding)
- ;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312
- ;; as GBK, because some mailers are broken.
- (cond [(or (regexp-match? re:iso encoding)
- (regexp-match? re:us-ascii encoding))
- (if (bytes? encoding) #"WINDOWS-1252" "WINDOWS-1252")]
- [(regexp-match? re:gb encoding)
- (if (bytes? encoding) #"GBK" "GBK")]
- [(regexp-match? re:ks_c encoding)
- (if (bytes? encoding) #"CP949" "CP949")]
- [else encoding]))
+(define (generalize-encoding encoding)
+ ;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312
+ ;; as GBK, because some mailers are broken.
+ (cond [(or (regexp-match? re:iso encoding)
+ (regexp-match? re:us-ascii encoding))
+ (if (bytes? encoding) #"WINDOWS-1252" "WINDOWS-1252")]
+ [(regexp-match? re:gb encoding)
+ (if (bytes? encoding) #"GBK" "GBK")]
+ [(regexp-match? re:ks_c encoding)
+ (if (bytes? encoding) #"CP949" "CP949")]
+ [else encoding]))
- (define (decode-for-header s)
- (and s
- (let ([m (regexp-match re:encoded
- (string->bytes/latin-1 s (char->integer #\?)))])
- (if m
- (let ([s ((if (member (cadddr m) '(#"q" #"Q"))
- ;; quoted-printable, with special _ handling
- (lambda (x)
- (qp-decode (regexp-replace* #rx#"_" x #" ")))
- ;; base64:
- base64-decode)
- (cadddr (cdr m)))]
- [encoding (caddr m)])
- (string-append
- (decode-for-header (bytes->string/latin-1 (cadr m)))
- (let ([encoding (generalize-encoding encoding)])
- (cond
- [(regexp-match? re:utf-8 encoding)
- (bytes->string/utf-8 s #\?)]
- [else (let ([c (bytes-open-converter
- (bytes->string/latin-1 encoding)
- "UTF-8")])
- (if c
- (let-values ([(r got status)
- (bytes-convert c s)])
- (bytes-close-converter c)
- (if (eq? status 'complete)
- (bytes->string/utf-8 r #\?)
- (bytes->string/latin-1 s)))
- (bytes->string/latin-1 s)))]))
- (let ([rest (cadddr (cddr m))])
- (let ([rest
- ;; A CR-LF-space-encoding sequence means that we
- ;; should drop the space.
- (if (and (> (bytes-length rest) 4)
- (= 13 (bytes-ref rest 0))
- (= 10 (bytes-ref rest 1))
- (= 32 (bytes-ref rest 2))
- (let ([m (regexp-match-positions
- re:encoded rest)])
- (and m (= (caaddr m) 5))))
- (subbytes rest 3)
- rest)])
- (decode-for-header (bytes->string/latin-1 rest))))))
- s)))))
+(define (decode-for-header s)
+ (and s
+ (let ([m (regexp-match re:encoded
+ (string->bytes/latin-1 s (char->integer #\?)))])
+ (if m
+ (let ([s ((if (member (cadddr m) '(#"q" #"Q"))
+ ;; quoted-printable, with special _ handling
+ (lambda (x)
+ (qp-decode (regexp-replace* #rx#"_" x #" ")))
+ ;; base64:
+ base64-decode)
+ (cadddr (cdr m)))]
+ [encoding (caddr m)])
+ (string-append
+ (decode-for-header (bytes->string/latin-1 (cadr m)))
+ (let ([encoding (generalize-encoding encoding)])
+ (cond
+ [(regexp-match? re:utf-8 encoding)
+ (bytes->string/utf-8 s #\?)]
+ [else (let ([c (bytes-open-converter
+ (bytes->string/latin-1 encoding)
+ "UTF-8")])
+ (if c
+ (let-values ([(r got status)
+ (bytes-convert c s)])
+ (bytes-close-converter c)
+ (if (eq? status 'complete)
+ (bytes->string/utf-8 r #\?)
+ (bytes->string/latin-1 s)))
+ (bytes->string/latin-1 s)))]))
+ (let ([rest (cadddr (cddr m))])
+ (let ([rest
+ ;; A CR-LF-space-encoding sequence means that we
+ ;; should drop the space.
+ (if (and (> (bytes-length rest) 4)
+ (= 13 (bytes-ref rest 0))
+ (= 10 (bytes-ref rest 1))
+ (= 32 (bytes-ref rest 2))
+ (let ([m (regexp-match-positions
+ re:encoded rest)])
+ (and m (= (caaddr m) 5))))
+ (subbytes rest 3)
+ rest)])
+ (decode-for-header (bytes->string/latin-1 rest))))))
+ s))))
diff --git a/collects/net/uri-codec.ss b/collects/net/uri-codec.ss
index 69f4d869ec..cc7bec9b96 100644
--- a/collects/net/uri-codec.ss
+++ b/collects/net/uri-codec.ss
@@ -1,6 +1,6 @@
-(module uri-codec mzscheme
- (require mzlib/unit "uri-codec-sig.ss" "uri-codec-unit.ss")
+#lang scheme/base
+(require mzlib/unit "uri-codec-sig.ss" "uri-codec-unit.ss")
- (provide-signature-elements uri-codec^)
+(provide-signature-elements uri-codec^)
- (define-values/invoke-unit/infer uri-codec@))
+(define-values/invoke-unit/infer uri-codec@)
diff --git a/collects/net/url-structs.ss b/collects/net/url-structs.ss
index 9625ee10b1..f20f668d52 100644
--- a/collects/net/url-structs.ss
+++ b/collects/net/url-structs.ss
@@ -1,18 +1,20 @@
-(module url-structs mzscheme
- (require mzlib/contract
- mzlib/serialize)
+#lang scheme/base
+(require scheme/contract
+ scheme/serialize)
- (define-serializable-struct url (scheme user host port path-absolute? path query fragment))
- (define-serializable-struct path/param (path param))
+(define-serializable-struct url
+ (scheme user host port path-absolute? path query fragment)
+ #:mutable)
+(define-serializable-struct path/param (path param))
- (provide/contract
- (struct url ([scheme (or/c false/c string?)]
- [user (or/c false/c string?)]
- [host (or/c false/c string?)]
- [port (or/c false/c number?)]
- [path-absolute? boolean?]
- [path (listof path/param?)]
- [query (listof (cons/c symbol? (or/c string? false/c)))]
- [fragment (or/c false/c string?)]))
- (struct path/param ([path (or/c string? (symbols 'up 'same))]
- [param (listof string?)]))))
+(provide/contract
+ (struct url ([scheme (or/c false/c string?)]
+ [user (or/c false/c string?)]
+ [host (or/c false/c string?)]
+ [port (or/c false/c number?)]
+ [path-absolute? boolean?]
+ [path (listof path/param?)]
+ [query (listof (cons/c symbol? (or/c string? false/c)))]
+ [fragment (or/c false/c string?)]))
+ (struct path/param ([path (or/c string? (symbols 'up 'same))]
+ [param (listof string?)])))
diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss
index 86bdf3c0bb..a23a6749cb 100644
--- a/collects/net/url-unit.ss
+++ b/collects/net/url-unit.ss
@@ -9,229 +9,230 @@
;; "impure" = they have text waiting
;; "pure" = the MIME headers have been read
-(module url-unit scheme/base
- (require mzlib/file
- mzlib/unit
- mzlib/port
- mzlib/list
- mzlib/string
- mzlib/kw
- "url-structs.ss"
- "uri-codec.ss"
- "url-sig.ss"
- "tcp-sig.ss")
- (provide url@)
+#lang scheme/unit
+(require scheme/port
+ "url-structs.ss"
+ "uri-codec.ss"
+ "url-sig.ss"
+ "tcp-sig.ss")
- (define-unit url@
- (import tcp^)
- (export url^)
+(import tcp^)
+(export url^)
- (define-struct (url-exception exn:fail) ())
+(define-struct (url-exception exn:fail) ())
- (define file-url-path-convention-type (make-parameter (system-path-convention-type)))
+(define file-url-path-convention-type (make-parameter (system-path-convention-type)))
- (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))
- (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))
- (map (lambda (v)
- (list (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))
+ (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))
+ (map (lambda (v)
+ (list (string->immutable-string (car v))
+ (string->immutable-string (cadr v))
+ (caddr v)))
+ v))))
- (define (url-error fmt . args)
- (raise (make-url-exception
- (apply format fmt
- (map (lambda (arg) (if (url? arg) (url->string arg) arg))
- args))
- (current-continuation-marks))))
+(define (url-error fmt . args)
+ (raise (make-url-exception
+ (apply format fmt
+ (map (lambda (arg) (if (url? arg) (url->string arg) arg))
+ args))
+ (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])
- (when (and (equal? scheme "file")
- (not (url-path-absolute? url)))
- (raise-mismatch-error 'url->string
- "cannot convert relative file URL to a string: "
- url))
- (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!
- )
- (if (equal? "file" scheme) ; always need "//" for "file" URLs
- "//"
- ""))
- (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])
+ (when (and (equal? scheme "file")
+ (not (url-path-absolute? url)))
+ (raise-mismatch-error 'url->string
+ "cannot convert relative file URL to a string: "
+ url))
+ (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!
+ )
+ (if (equal? "file" scheme) ; always need "//" for "file" URLs
+ "//"
+ ""))
+ (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 [kind (system-path-convention-type)])
- (let ([strs (map path/param-path (url-path url))]
- [string->path-element/same
- (lambda (e)
- (if (symbol? e)
- e
- (if (string=? e "")
- 'same
- (bytes->path-element (string->bytes/locale e) kind))))]
- [string->path/win (lambda (s)
- (bytes->path (string->bytes/utf-8 s) 'windows))])
- (if (and (url-path-absolute? url)
- (eq? 'windows kind))
- ;; If initial path is "", then build UNC path.
- (cond
- [(not (url-path-absolute? url))
- (apply build-path (map string->path-element/same strs))]
- [(and ((length strs) . >= . 3)
- (equal? (car strs) ""))
- (apply build-path
- (string->path/win
- (string-append "\\\\" (cadr strs) "\\" (caddr strs) "\\"))
- (map string->path-element/same (cdddr strs)))]
- [(pair? strs)
- (apply build-path (string->path/win (car strs))
- (map string->path-element/same (cdr strs)))]
- [else (build-path)]) ; error
- (let ([elems (map string->path-element/same strs)])
- (if (url-path-absolute? url)
- (apply build-path (bytes->path #"/" 'unix) elems)
- (apply build-path elems))))))
+(define (file://->path url [kind (system-path-convention-type)])
+ (let ([strs (map path/param-path (url-path url))]
+ [string->path-element/same
+ (lambda (e)
+ (if (symbol? e)
+ e
+ (if (string=? e "")
+ 'same
+ (bytes->path-element (string->bytes/locale e) kind))))]
+ [string->path/win (lambda (s)
+ (bytes->path (string->bytes/utf-8 s) 'windows))])
+ (if (and (url-path-absolute? url)
+ (eq? 'windows kind))
+ ;; If initial path is "", then build UNC path.
+ (cond
+ [(not (url-path-absolute? url))
+ (apply build-path (map string->path-element/same strs))]
+ [(and ((length strs) . >= . 3)
+ (equal? (car strs) ""))
+ (apply build-path
+ (string->path/win
+ (string-append "\\\\" (cadr strs) "\\" (caddr strs) "\\"))
+ (map string->path-element/same (cdddr strs)))]
+ [(pair? strs)
+ (apply build-path (string->path/win (car strs))
+ (map string->path-element/same (cdr strs)))]
+ [else (build-path)]) ; error
+ (let ([elems (map string->path-element/same strs)])
+ (if (url-path-absolute? url)
+ (apply build-path (bytes->path #"/" 'unix) elems)
+ (apply build-path elems))))))
- ;; 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/kw (get-impure-port url #:optional [strings '()])
- (getpost-impure-port #t url #f strings))
+;; get-impure-port : url [x list (str)] -> in-port
+(define (get-impure-port url [strings '()])
+ (getpost-impure-port #t url #f strings))
- ;; post-impure-port : url x bytes [x list (str)] -> in-port
- (define/kw (post-impure-port url post-data #:optional [strings '()])
- (getpost-impure-port #f url post-data strings))
+;; post-impure-port : url x bytes [x list (str)] -> in-port
+(define (post-impure-port 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/kw (get-pure-port url #:optional [strings '()])
- (getpost-pure-port #t url #f strings))
+;; get-pure-port : url [x list (str)] -> in-port
+(define (get-pure-port url [strings '()])
+ (getpost-pure-port #t url #f strings))
- ;; post-pure-port : url bytes [x list (str)] -> in-port
- (define/kw (post-pure-port url post-data #:optional [strings '()])
- (getpost-pure-port #f url post-data strings))
+;; post-pure-port : url bytes [x list (str)] -> in-port
+(define (post-pure-port 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))
- ;; 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)
+;; 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! 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
@@ -239,352 +240,338 @@
(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
+ (if (null? (url-path R)) ;; => R has empty path
(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)))
+ (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
- (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))
+ (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)))]))
+(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 implicitly change urls
- ;; with paths segments "." and ".." at the end
- ;; into "./" and "../" respectively
- (define (remove-dot-segments path)
- (let loop ([path path] [result '()])
- (if (null? path)
- (reverse result)
- (let ([fst (path/param-path (car path))]
- [rst (cdr path)])
- (loop rst
- (cond
- [(and (eq? fst 'same) (null? rst))
- (cons (make-path/param "" '()) result)] ; [*]
- [(eq? fst 'same)
- result]
- [(and (eq? fst 'up) (null? rst) (not (null? result)))
- (cons (make-path/param "" '()) (cdr result))] ; [*]
- [(and (eq? fst 'up) (not (null? result)))
- (cdr result)]
- [(and (eq? fst 'up) (null? result))
- ;; when we go up too far, just drop the "up"s.
- result]
- [else
- (cons (car path) result)]))))))
+;; cribbed from 5.2.4 in rfc 3986
+;; the strange [*] cases implicitly change urls
+;; with paths segments "." and ".." at the end
+;; into "./" and "../" respectively
+(define (remove-dot-segments path)
+ (let loop ([path path] [result '()])
+ (if (null? path)
+ (reverse result)
+ (let ([fst (path/param-path (car path))]
+ [rst (cdr path)])
+ (loop rst
+ (cond
+ [(and (eq? fst 'same) (null? rst))
+ (cons (make-path/param "" '()) result)] ; [*]
+ [(eq? fst 'same)
+ result]
+ [(and (eq? fst 'up) (null? rst) (not (null? result)))
+ (cons (make-path/param "" '()) (cdr result))] ; [*]
+ [(and (eq? fst 'up) (not (null? result)))
+ (cdr result)]
+ [(and (eq? fst 'up) (null? result))
+ ;; when we go up too far, just drop the "up"s.
+ result]
+ [else
+ (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)])))
+;; 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) "")))
+;; 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)
+(define character-set-size 256)
- ;; netscape/string->url : str -> url
- (define (netscape/string->url string)
- (let ([url (string->url string)])
- (cond [(url-scheme url) url]
- [(string=? string "")
- (url-error "Can't resolve empty string as URL")]
- [else (set-url-scheme! url
- (if (char=? (string-ref string 0) #\/) "file" "http"))
- url])))
+;; netscape/string->url : str -> url
+(define (netscape/string->url string)
+ (let ([url (string->url string)])
+ (cond [(url-scheme url) url]
+ [(string=? string "")
+ (url-error "Can't resolve empty string as URL")]
+ [else (set-url-scheme! url
+ (if (char=? (string-ref string 0) #\/) "file" "http"))
+ url])))
- ;; URL parsing regexp
- ;; this is following the regexp in Appendix B of rfc 3986, except for using
- ;; `*' instead of `+' for the scheme part (it is checked later anyway, and
- ;; we don't want to parse it as a path element), and the user@host:port is
- ;; parsed here.
- (define url-rx
- (regexp (string-append
- "^"
- "(?:" ; / scheme-colon-opt
- "([^:/?#]*)" ; | #1 = scheme-opt
- ":)?" ; \
- "(?://" ; / slash-slash-authority-opt
- "(?:" ; | / user-at-opt
- "([^/?#@]*)" ; | | #2 = user-opt
- "@)?" ; | \
- "([^/?#:]*)?" ; | #3 = host-opt
- "(?::" ; | / colon-port-opt
- "([0-9]*)" ; | | #4 = port-opt
- ")?" ; | \
- ")?" ; \
- "([^?#]*)" ; #5 = path
- "(?:\\?" ; / question-query-opt
- "([^#]*)" ; | #6 = query-opt
- ")?" ; \
- "(?:#" ; / hash-fragment-opt
- "(.*)" ; | #7 = fragment-opt
- ")?" ; \
- "$")))
+;; URL parsing regexp
+;; this is following the regexp in Appendix B of rfc 3986, except for using
+;; `*' instead of `+' for the scheme part (it is checked later anyway, and
+;; we don't want to parse it as a path element), and the user@host:port is
+;; parsed here.
+(define url-rx
+ (regexp (string-append
+ "^"
+ "(?:" ; / scheme-colon-opt
+ "([^:/?#]*)" ; | #1 = scheme-opt
+ ":)?" ; \
+ "(?://" ; / slash-slash-authority-opt
+ "(?:" ; | / user-at-opt
+ "([^/?#@]*)" ; | | #2 = user-opt
+ "@)?" ; | \
+ "([^/?#:]*)?" ; | #3 = host-opt
+ "(?::" ; | / colon-port-opt
+ "([0-9]*)" ; | | #4 = port-opt
+ ")?" ; | \
+ ")?" ; \
+ "([^?#]*)" ; #5 = path
+ "(?:\\?" ; / question-query-opt
+ "([^#]*)" ; | #6 = query-opt
+ ")?" ; \
+ "(?:#" ; / hash-fragment-opt
+ "(.*)" ; | #7 = fragment-opt
+ ")?" ; \
+ "$")))
- ;; string->url : str -> url
- ;; Original version by Neil Van Dyke
- (define (string->url str)
- (apply
- (lambda (scheme user host port path query fragment)
- (when (and scheme (not (regexp-match? #rx"^[a-zA-Z][a-zA-Z0-9+.-]*$"
- scheme)))
- (url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
- ;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
- (let ([win-file? (and (or (equal? "" port)
- (not port))
- (equal? "file" scheme)
- (eq? 'windows (file-url-path-convention-type))
- (not (equal? host "")))])
- (when win-file?
- (if (equal? "" port)
- (set! path (string-append host ":" path))
- (set! path (if path
- (if host
- (string-append host "/" path)
- path)
- host)))
- (set! port #f)
- (set! host ""))
- (let* ([scheme (and scheme (string-downcase scheme))]
- [host (and host (string-downcase host))]
- [user (uri-decode/maybe user)]
- [port (and port (string->number port))]
- [abs? (or (equal? "file" scheme)
- (regexp-match? #rx"^/" path))]
- [path (if win-file?
- (separate-windows-path-strings path)
- (separate-path-strings path))]
- [query (if query (form-urlencoded->alist query) '())]
- [fragment (uri-decode/maybe fragment)])
- (make-url scheme user host port abs? path query fragment))))
- (cdr (or (regexp-match url-rx str)
- (url-error "Invalid URL string: ~e" str)))))
+;; string->url : str -> url
+;; Original version by Neil Van Dyke
+(define (string->url str)
+ (apply
+ (lambda (scheme user host port path query fragment)
+ (when (and scheme (not (regexp-match? #rx"^[a-zA-Z][a-zA-Z0-9+.-]*$"
+ scheme)))
+ (url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
+ ;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
+ (let ([win-file? (and (or (equal? "" port) (not port))
+ (equal? "file" scheme)
+ (eq? 'windows (file-url-path-convention-type))
+ (not (equal? host "")))])
+ (when win-file?
+ (if (equal? "" port)
+ (set! path (string-append host ":" path))
+ (set! path (if path
+ (if host
+ (string-append host "/" path)
+ path)
+ host)))
+ (set! port #f)
+ (set! host ""))
+ (let* ([scheme (and scheme (string-downcase scheme))]
+ [host (and host (string-downcase host))]
+ [user (uri-decode/maybe user)]
+ [port (and port (string->number port))]
+ [abs? (or (equal? "file" scheme)
+ (regexp-match? #rx"^/" path))]
+ [path (if win-file?
+ (separate-windows-path-strings path)
+ (separate-path-strings path))]
+ [query (if query (form-urlencoded->alist query) '())]
+ [fragment (uri-decode/maybe fragment)])
+ (make-url scheme user host port abs? path query fragment))))
+ (cdr (or (regexp-match url-rx str)
+ (url-error "Invalid URL string: ~e" str)))))
- (define (uri-decode/maybe f)
- ;; 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* #rx"%([^0-9a-fA-F])" f "%25\\1"))))
+(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* #rx"%([^0-9a-fA-F])" f "%25\\1"))))
- ;; 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))))
+;; 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-windows-path-strings str)
- (url-path (path->url (bytes->path (string->bytes/utf-8 str) 'windows))))
+(define (separate-windows-path-strings str)
+ (url-path (path->url (bytes->path (string->bytes/utf-8 str) 'windows))))
- (define (separate-params s)
- (let ([lst (map path-segment-decode (regexp-split #rx";" s))])
- (make-path/param (car lst) (cdr lst))))
+(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-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 (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 (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-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))))]))
+(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))))]))
- (define (path->url path)
- (let ([url-path (let loop ([path (simplify-path path #f)][accum null])
- (let-values ([(base name dir?) (split-path path)])
- (cond
- [(not base)
- (append (map
- (lambda (s)
- (make-path/param s null))
- (if (eq? (path-convention-type path) 'windows)
- ;; For Windows, massage the root:
- (let ([s (regexp-replace
- #rx"[/\\\\]$"
- (bytes->string/utf-8
- (path->bytes name))
- "")])
- (cond
- [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
- ;; \\?\: path:
- (regexp-split #rx"[/\\]+" (substring s 4))]
- [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s)
- ;; \\?\ UNC path:
- (regexp-split #rx"[/\\]+" (substring s 7))]
- [(regexp-match? #rx"^[/\\]" s)
- ;; UNC path:
- (regexp-split #rx"[/\\]+" s)]
- [else
- (list s)]))
- ;; On other platforms, we drop the root:
- null))
- accum)]
- [else
- (let ([accum (cons (make-path/param
- (if (symbol? name)
- name
- (bytes->string/utf-8
- (path-element->bytes name)))
- null)
- accum)])
- (if (eq? base 'relative)
- accum
- (loop base accum)))])))])
- (make-url "file" #f "" #f (absolute-path? path) url-path '() #f)))
+(define (path->url path)
+ (let ([url-path
+ (let loop ([path (simplify-path path #f)][accum null])
+ (let-values ([(base name dir?) (split-path path)])
+ (cond
+ [(not base)
+ (append (map
+ (lambda (s)
+ (make-path/param s null))
+ (if (eq? (path-convention-type path) 'windows)
+ ;; For Windows, massage the root:
+ (let ([s (regexp-replace
+ #rx"[/\\\\]$"
+ (bytes->string/utf-8 (path->bytes name))
+ "")])
+ (cond
+ [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
+ ;; \\?\: path:
+ (regexp-split #rx"[/\\]+" (substring s 4))]
+ [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s)
+ ;; \\?\ UNC path:
+ (regexp-split #rx"[/\\]+" (substring s 7))]
+ [(regexp-match? #rx"^[/\\]" s)
+ ;; UNC path:
+ (regexp-split #rx"[/\\]+" s)]
+ [else
+ (list s)]))
+ ;; On other platforms, we drop the root:
+ null))
+ accum)]
+ [else
+ (let ([accum (cons (make-path/param
+ (if (symbol? name)
+ name
+ (bytes->string/utf-8
+ (path-element->bytes name)))
+ null)
+ accum)])
+ (if (eq? base 'relative)
+ accum
+ (loop base accum)))])))])
+ (make-url "file" #f "" #f (absolute-path? path) url-path '() #f)))
- (define (url->path url [kind (system-path-convention-type)])
- (file://->path url kind))
-
- ;; delete-pure-port : url [x list (str)] -> in-port
- (define/kw (delete-pure-port url #:optional [strings '()])
- (method-pure-port 'delete url #f strings))
+(define (url->path url [kind (system-path-convention-type)])
+ (file://->path url kind))
- ;; delete-impure-port : url [x list (str)] -> in-port
- (define/kw (delete-impure-port url #:optional [strings '()])
- (method-impure-port 'delete url #f strings))
+;; delete-pure-port : url [x list (str)] -> in-port
+(define (delete-pure-port url [strings '()])
+ (method-pure-port 'delete url #f strings))
- ;; head-pure-port : url [x list (str)] -> in-port
- (define/kw (head-pure-port url #:optional [strings '()])
- (method-pure-port 'head url #f strings))
+;; delete-impure-port : url [x list (str)] -> in-port
+(define (delete-impure-port url [strings '()])
+ (method-impure-port 'delete url #f strings))
- ;; head-impure-port : url [x list (str)] -> in-port
- (define/kw (head-impure-port url #:optional [strings '()])
- (method-impure-port 'head url #f strings))
+;; head-pure-port : url [x list (str)] -> in-port
+(define (head-pure-port url [strings '()])
+ (method-pure-port 'head url #f strings))
- ;; put-pure-port : url bytes [x list (str)] -> in-port
- (define/kw (put-pure-port url put-data #:optional [strings '()])
- (method-pure-port 'put url put-data strings))
+;; head-impure-port : url [x list (str)] -> in-port
+(define (head-impure-port url [strings '()])
+ (method-impure-port 'head url #f strings))
- ;; put-impure-port : url x bytes [x list (str)] -> in-port
- (define/kw (put-impure-port url put-data #:optional [strings '()])
- (method-impure-port 'put url put-data strings))
+;; put-pure-port : url bytes [x list (str)] -> in-port
+(define (put-pure-port url put-data [strings '()])
+ (method-pure-port 'put url put-data strings))
- ;; method-impure-port : symbol x url x list (str) -> in-port
- (define (method-impure-port method url data strings)
- (let ([scheme (url-scheme url)])
- (cond [(not scheme)
- (schemeless-url url)]
- [(or (string=? scheme "http")
- (string=? scheme "https"))
- (http://method-impure-port method url data strings)]
- [(string=? scheme "file")
- (url-error "There are no impure file: ports")]
- [else (url-error "Scheme ~a unsupported" scheme)])))
+;; put-impure-port : url x bytes [x list (str)] -> in-port
+(define (put-impure-port url put-data [strings '()])
+ (method-impure-port 'put url put-data strings))
- ;; method-pure-port : symbol x url x list (str) -> in-port
- (define (method-pure-port method url data strings)
- (let ([scheme (url-scheme url)])
- (cond [(not scheme)
- (schemeless-url url)]
- [(or (string=? scheme "http")
- (string=? scheme "https"))
- (let ([port (http://method-impure-port
- method url 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)])))
+;; method-impure-port : symbol x url x list (str) -> in-port
+(define (method-impure-port method url data strings)
+ (let ([scheme (url-scheme url)])
+ (cond [(not scheme)
+ (schemeless-url url)]
+ [(or (string=? scheme "http") (string=? scheme "https"))
+ (http://method-impure-port method url data strings)]
+ [(string=? scheme "file")
+ (url-error "There are no impure file: ports")]
+ [else (url-error "Scheme ~a unsupported" scheme)])))
- ;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port
- (define (http://method-impure-port method url data strings)
- (let*-values
- ([(method) (case method
- [(get) "GET"] [(post) "POST"] [(head) "HEAD"]
- [(put) "PUT"] [(delete) "DELETE"]
- [else (url-error "unsupported method: ~a" method)])]
- [(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 method " " access-string " HTTP/1.0")
- (println "Host: " (url-host url)
- (let ([p (url-port url)]) (if p (format ":~a" p) "")))
- (when data (println "Content-Length: " (bytes-length data)))
- (for-each println strings)
- (println)
- (when data (display data client->server))
- (flush-output client->server)
- (tcp-abandon-port client->server)
- server->client))
+;; method-pure-port : symbol x url x list (str) -> in-port
+(define (method-pure-port method url data strings)
+ (let ([scheme (url-scheme url)])
+ (cond [(not scheme)
+ (schemeless-url url)]
+ [(or (string=? scheme "http") (string=? scheme "https"))
+ (let ([port (http://method-impure-port
+ method url 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)])))
- ))
+;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port
+(define (http://method-impure-port method url data strings)
+ (let*-values
+ ([(method) (case method
+ [(get) "GET"] [(post) "POST"] [(head) "HEAD"]
+ [(put) "PUT"] [(delete) "DELETE"]
+ [else (url-error "unsupported method: ~a" method)])]
+ [(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 method " " access-string " HTTP/1.0")
+ (println "Host: " (url-host url)
+ (let ([p (url-port url)]) (if p (format ":~a" p) "")))
+ (when data (println "Content-Length: " (bytes-length data)))
+ (for-each println strings)
+ (println)
+ (when data (display data client->server))
+ (flush-output client->server)
+ (tcp-abandon-port client->server)
+ server->client))
diff --git a/collects/net/url.ss b/collects/net/url.ss
index cd1ce2e526..8068fe6f22 100644
--- a/collects/net/url.ss
+++ b/collects/net/url.ss
@@ -1,63 +1,53 @@
-(module url mzscheme
- (require mzlib/unit
- mzlib/contract
- "url-structs.ss"
- "url-sig.ss"
- "url-unit.ss"
- "tcp-sig.ss"
- "tcp-unit.ss")
+#lang scheme/base
+(require scheme/unit
+ scheme/contract
+ (only-in mzlib/contract opt->)
+ "url-structs.ss"
+ "url-sig.ss"
+ "url-unit.ss"
+ "tcp-sig.ss"
+ "tcp-unit.ss")
- (define-compound-unit/infer url+tcp@
- (import) (export url^)
- (link tcp@ url@))
+(define-compound-unit/infer url+tcp@
+ (import) (export url^)
+ (link tcp@ url@))
- (define-values/invoke-unit/infer url+tcp@)
+(define-values/invoke-unit/infer url+tcp@)
- (provide
- (struct url (scheme
- user
- host
- port
- path-absolute?
- path
- query
- fragment))
- (struct path/param (path param)))
+(provide (struct-out url) (struct-out path/param))
- (provide/contract
- (string->url ((or/c bytes? string?) . -> . url?))
- (path->url ((or/c path-string? path-for-some-system?) . -> . url?))
- (url->string (url? . -> . string?))
- (url->path ((url?) ((one-of/c 'unix 'windows)) . opt-> . path-for-some-system?))
-
- (get-pure-port (opt-> (url?) ((listof string?)) input-port?))
- (get-impure-port (opt-> (url?) ((listof string?)) input-port?))
- (post-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
- (post-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
- (head-pure-port (opt-> (url?) ((listof string?)) input-port?))
- (head-impure-port (opt-> (url?) ((listof string?)) input-port?))
- (delete-pure-port (opt-> (url?) ((listof string?)) input-port?))
- (delete-impure-port (opt-> (url?) ((listof string?)) input-port?))
- (put-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
- (put-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
- (display-pure-port (input-port? . -> . void?))
- (purify-port (input-port? . -> . string?))
- (netscape/string->url (string? . -> . url?))
- (call/input-url (case->
- (-> url?
- (-> url? input-port?)
- (-> input-port? any)
- any)
- (-> url?
- (-> url? (listof string?) input-port?)
- (-> input-port? any)
- (listof string?)
- any)))
- (combine-url/relative (url? string? . -> . url?))
- (url-exception? (any/c . -> . boolean?))
- (current-proxy-servers
- (parameter/c (or/c false/c (listof (list/c string? string? number?)))))
- (file-url-path-convention-type
- (parameter/c (one-of/c 'unix 'windows))))
- )
+(provide/contract
+ (string->url ((or/c bytes? string?) . -> . url?))
+ (path->url ((or/c path-string? path-for-some-system?) . -> . url?))
+ (url->string (url? . -> . string?))
+ (url->path ((url?) ((one-of/c 'unix 'windows)) . opt-> . path-for-some-system?))
+ (get-pure-port (opt-> (url?) ((listof string?)) input-port?))
+ (get-impure-port (opt-> (url?) ((listof string?)) input-port?))
+ (post-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
+ (post-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
+ (head-pure-port (opt-> (url?) ((listof string?)) input-port?))
+ (head-impure-port (opt-> (url?) ((listof string?)) input-port?))
+ (delete-pure-port (opt-> (url?) ((listof string?)) input-port?))
+ (delete-impure-port (opt-> (url?) ((listof string?)) input-port?))
+ (put-pure-port (opt-> (url? (or/c false/c bytes?)) ((listof string?)) input-port?))
+ (put-impure-port (opt-> (url? bytes?) ((listof string?)) input-port?))
+ (display-pure-port (input-port? . -> . void?))
+ (purify-port (input-port? . -> . string?))
+ (netscape/string->url (string? . -> . url?))
+ (call/input-url (case->
+ (-> url?
+ (-> url? input-port?)
+ (-> input-port? any)
+ any)
+ (-> url?
+ (-> url? (listof string?) input-port?)
+ (-> input-port? any)
+ (listof string?)
+ any)))
+ (combine-url/relative (url? string? . -> . url?))
+ (url-exception? (any/c . -> . boolean?))
+ (current-proxy-servers
+ (parameter/c (or/c false/c (listof (list/c string? string? number?)))))
+ (file-url-path-convention-type
+ (parameter/c (one-of/c 'unix 'windows))))