From 0d41afdb6d470299616dd1db944ce4577c5a64bf Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 15 May 2008 16:55:15 +0000 Subject: [PATCH] reformatting svn: r9853 --- collects/net/base64-sig.ss | 1 - collects/net/base64.ss | 10 +- collects/net/cgi-unit.ss | 362 +++++---- collects/net/cgi.ss | 8 +- collects/net/cookie-unit.ss | 473 ++++++------ collects/net/cookie.ss | 8 +- collects/net/dns-unit.ss | 609 ++++++++------- collects/net/dns.ss | 8 +- collects/net/ftp.ss | 8 +- collects/net/head-unit.ss | 618 ++++++++------- collects/net/head.ss | 8 +- collects/net/imap-unit.ss | 1059 +++++++++++++------------- collects/net/imap.ss | 81 +- collects/net/mime-sig.ss | 17 +- collects/net/mime-unit.ss | 1325 ++++++++++++++++----------------- collects/net/mime-util.ss | 195 +++-- collects/net/mime.ss | 34 +- collects/net/nntp.ss | 8 +- collects/net/pop3.ss | 8 +- collects/net/qp-unit.ss | 254 +++---- collects/net/qp.ss | 8 +- collects/net/sendmail-unit.ss | 214 +++--- collects/net/sendmail.ss | 8 +- collects/net/smtp.ss | 8 +- collects/net/ssl-tcp-unit.ss | 106 ++- collects/net/tcp-redirect.ss | 233 +++--- collects/net/tcp-unit.ss | 8 +- collects/net/unihead.ss | 218 +++--- collects/net/uri-codec.ss | 8 +- collects/net/url-structs.ss | 34 +- collects/net/url-unit.ss | 1029 +++++++++++++------------ collects/net/url.ss | 106 ++- 32 files changed, 3495 insertions(+), 3579 deletions(-) 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))))