diff --git a/collects/net/mime-unit.ss b/collects/net/mime-unit.ss index 1d41833ddf..21a6acc88a 100644 --- a/collects/net/mime-unit.ss +++ b/collects/net/mime-unit.ss @@ -146,72 +146,67 @@ ;; get-headers : input-port -> string ;; returns the header part of a message/part conforming to rfc822, and ;; rfc2045. - (define get-headers - (lambda (in) - (let loop ([headers ""] [ln (read-line in 'any)]) - (cond [(eof-object? ln) - ;; (raise (make-unexpected-termination "eof reached! while parsing headers")) - (warning "premature eof while parsing headers") - headers] - [(string=? ln "") headers] - [else - ;; Quoting rfc822: - ;; " Headers occur before the message body and are - ;; terminated by a null line (i.e., two contiguous - ;; CRLFs)." - ;; That is: Two empty lines. But most MUAs seem to count - ;; the CRLF ending the last field (header) as the first - ;; CRLF of the null line. - (loop (string-append headers ln CRLF) - (read-line in 'any))])))) + (define (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 - (lambda () - (make-disposition - 'inline ;; type - "" ;; filename - #f ;; creation - #f ;; modification - #f ;; read - #f ;; size - null ;; params - ))) + (define (make-default-disposition) + (make-disposition + 'inline ;; type + "" ;; filename + #f ;; creation + #f ;; modification + #f ;; read + #f ;; size + null ;; params + )) - (define make-default-entity - (lambda () - (make-entity - 'text ;; type - 'plain ;; subtype - 'us-ascii ;; charset - '7bit ;; encoding - (make-default-disposition) ;; disposition - null ;; params - "" ;; id - "" ;; description - null ;; other MIME fields (MIME-extension-fields) - null ;; fields - null ;; parts - null ;; body - ))) + (define (make-default-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 - (lambda () - (make-message 1.0 (make-default-entity) null))) + (define (make-default-message) + (make-message 1.0 (make-default-entity) null)) - (define mime-decode - (lambda (entity input) - (set-entity-body! - entity - (case (entity-encoding entity) - [(quoted-printable) - (lambda (output) - (qp-decode-stream input output))] - [(base64) - (lambda (output) - (base64-decode-stream input output))] - [else ;; 7bit, 8bit, binary - (lambda (output) - (copy-port input output))])))) + (define (mime-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)) @@ -245,11 +240,10 @@ ;; return mime structure msg))) - (define entity-boundary - (lambda (entity) - (let* ([params (entity-params entity)] - [ans (assoc "boundary" params)]) - (and ans (cdr ans))))) + (define (entity-boundary entity) + (let* ([params (entity-params entity)] + [ans (assoc "boundary" params)]) + (and ans (cdr ans)))) ;; ************************************************* ;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183 @@ -261,38 +255,37 @@ ;; close-delimiter transport-padding ;; [CRLF epilogue] ;; Returns a list of input ports, each one containing the correspongind part. - (define multipart-body - (lambda (input boundary) - (let* ([make-re (lambda (prefix) - (regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))] - [re (make-re "\r\n")]) - (letrec ([eat-part (lambda () - (let-values ([(pin pout) (make-pipe)]) - (let ([m (regexp-match re input 0 #f pout)]) - (cond - [(not m) - (close-output-port pout) - (values pin ;; part - #f ;; close-delimiter? - #t ;; eof reached? - )] - [(cadr m) - (close-output-port pout) - (values pin #t #f)] - [else - (close-output-port pout) - (values pin #f #f)]))))]) - ;; pre-amble is allowed to be completely empty: - (if (regexp-match-peek (make-re "^") input) - ;; No \r\f before first separator: - (read-line input) - ;; non-empty preamble: - (eat-part)) - (let loop () - (let-values ([(part close? eof?) (eat-part)]) - (cond (close? (list part)) - (eof? (list part)) - (else (cons part (loop)))))))))) + (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))])))))) ;; MIME-message-headers := entity-headers ;; fields @@ -300,11 +293,10 @@ ;; ; The ordering of the header ;; ; fields implied by this BNF ;; ; definition should be ignored. - (define MIME-message-headers - (lambda (headers) - (let ([message (make-default-message)]) - (entity-headers headers message #t) - message))) + (define (MIME-message-headers headers) + (let ([message (make-default-message)]) + (entity-headers headers message #t) + message)) ;; MIME-part-headers := entity-headers ;; [ fields ] @@ -314,63 +306,59 @@ ;; ; The ordering of the header ;; ; fields implied by this BNF ;; ; definition should be ignored. - (define MIME-part-headers - (lambda (headers) - (let ([message (make-default-message)]) - (entity-headers headers message #f) - message))) + (define (MIME-part-headers headers) + (let ([message (make-default-message)]) + (entity-headers headers message #f) + message)) ;; entity-headers := [ content CRLF ] ;; [ encoding CRLF ] ;; [ id CRLF ] ;; [ description CRLF ] ;; *( MIME-extension-field CRLF ) - (define entity-headers - (lambda (headers message version?) - (let ([entity (message-entity message)]) - (let-values ([(mime non-mime) (get-fields headers)]) - (let loop ([fields mime]) - (unless (null? fields) - ;; Process MIME field - (let ([trimmed-h (trim-comments (car fields))]) - (or (and version? (version trimmed-h message)) - (content trimmed-h entity) - (encoding trimmed-h entity) - (dispositione trimmed-h entity) - (id trimmed-h entity) - (description trimmed-h entity) - (MIME-extension-field trimmed-h entity)) - ;; keep going - (loop (cdr fields))))) - ;; NON-mime headers (or semantically incorrect). In order to make - ;; this implementation of rfc2045 robuts, we will save the header in - ;; the fields field of the message struct: - (set-message-fields! message non-mime) - ;; Return message - message)))) + (define (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 get-fields - (lambda (headers) - (let ([mime null] [non-mime null]) - (letrec ([store-field - (lambda (f) - (unless (string=? f "") - (if (mime-header? f) - (set! mime (append mime (list (trim-spaces f)))) - (set! non-mime (append non-mime (list (trim-spaces f)))))))]) - (let ([fields (extract-all-fields headers)]) - (for-each (lambda (p) - (store-field (format "~a: ~a" (car p) (cdr p)))) - fields)) - (values mime non-mime))))) + (define (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)))) (define re:content (regexp (format "^~a" (regexp-quote "content-" #f)))) (define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f)))) - (define mime-header? - (lambda (h) - (or (regexp-match re:content h) - (regexp-match re:mime h)))) + (define (mime-header? h) + (or (regexp-match? re:content h) + (regexp-match? re:mime h))) ;;; Headers ;;; Content-type follows this BNF syntax: @@ -380,103 +368,97 @@ ;; ; is ALWAYS case-insensitive. (define re:content-type (regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f)))) - (define content - (lambda (header entity) - (let* ([params (string-tokenizer #\; header)] - [one re:content-type] - [h (trim-all-spaces (car params))] - [target (regexp-match one h)] - [old-param (entity-params entity)]) - (and target - (set-entity-type! entity - (type (regexp-replace one h "\\1"))) ;; type - (set-entity-subtype! entity - (subtype (regexp-replace one h "\\2"))) ;; subtype - (set-entity-params! - entity - (append old-param - (let loop ([p (cdr params)] ;; parameters - [ans null]) - (cond [(null? p) ans] - [else - (let ([par-pair (parameter (trim-all-spaces (car p)))]) - (cond [par-pair - (when (string=? (car par-pair) "charset") - (set-entity-charset! entity (cdr par-pair))) - (loop (cdr p) - (append ans - (list par-pair)))] - [else - (warning "Invalid parameter for Content-Type: `~a'" (car p)) - ;; go on... - (loop (cdr p) ans)]))])))))))) + (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 rfc2183 Content-Disposition ;; disposition := "Content-Disposition" ":" ;; disposition-type ;; *(";" disposition-parm) (define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f)))) - (define dispositione - (lambda (header entity) - (let* ([params (string-tokenizer #\; header)] - [reg re:content-disposition] - [h (trim-all-spaces (car params))] - [target (regexp-match reg h)] - [disp-struct (entity-disposition entity)]) - (and target - (set-disposition-type! - disp-struct - (disp-type (regexp-replace reg h "\\1"))) - (disp-params (cdr params) disp-struct))))) + (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)))) ;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT (define re:mime-version (regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f)))) - (define version - (lambda (header message) - (let* ([reg re:mime-version] - [h (trim-all-spaces header)] - [target (regexp-match reg h)]) - (and target - (set-message-version! - message - (string->number (regexp-replace reg h "\\1.\\2"))))))) + (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")))))) ;; description := "Content-Description" ":" *text (define re:content-description (regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f)))) - (define description - (lambda (header entity) - (let* ([reg re:content-description] - [target (regexp-match reg header)]) - (and target - (set-entity-description! - entity - (trim-spaces (regexp-replace reg header "\\1"))))))) + (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")))))) ;; encoding := "Content-Transfer-Encoding" ":" mechanism (define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f)))) - (define encoding - (lambda (header entity) - (let* ([reg re:content-transfer-encoding] - [h (trim-all-spaces header)] - [target (regexp-match reg h)]) - (and target - (set-entity-encoding! - entity - (mechanism (regexp-replace reg h "\\1"))))))) + (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")))))) ;; id := "Content-ID" ":" msg-id (define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f)))) - (define id - (lambda (header entity) - (let* ([reg re:content-id] - [h (trim-all-spaces header)] - [target (regexp-match reg h)]) - (and target - (set-entity-id! - entity - (msg-id (regexp-replace reg h "\\1"))))))) + (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")))))) ;; From rfc822: ;; msg-id = "<" addr-spec ">" ; Unique message id @@ -487,84 +469,75 @@ ;; sub-domain = domain-ref / domain-literal ;; domain-literal = "[" *(dtext / quoted-pair) "]" ;; domain-ref = atom ; symbolic reference - (define msg-id - (lambda (str) - (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")] - [ans (regexp-match r str)]) - (if ans - str - (begin (warning "Invalid msg-id: ~a" str) str))))) + (define (msg-id str) + (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")] + [ans (regexp-match r str)]) + (if ans + str + (begin (warning "Invalid msg-id: ~a" str) str)))) ;; mechanism := "7bit" / "8bit" / "binary" / ;; "quoted-printable" / "base64" / ;; ietf-token / x-token - (define mechanism - (lambda (mech) - (if (not mech) - (raise (make-empty-mechanism)) - (let ([val (assoc (lowercase mech) mechanism-alist)]) - (or (and val (cdr val)) - (ietf-token mech) - (x-token mech)))))) + (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))))) ;; MIME-extension-field := ;; - (define MIME-extension-field - (lambda (header entity) - (let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")] - [target (regexp-match reg header)]) - (and target - (set-entity-other! - entity - (append (entity-other entity) - (list - (cons (regexp-replace reg header "\\1") - (trim-spaces (regexp-replace reg header "\\2")))))))))) + (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"))))))))) ;; type := discrete-type / composite-type - (define type - (lambda (value) - (if (not value) - (raise (make-empty-type)) - (or (discrete-type value) - (composite-type value))))) + (define (type value) + (if (not value) + (raise (make-empty-type)) + (or (discrete-type value) + (composite-type value)))) ;; disposition-type := "inline" / "attachment" / extension-token - (define disp-type - (lambda (value) - (if (not value) - (raise (make-empty-disposition-type)) - (let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)]) - (if val (cdr val) (extension-token value)))))) + (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))))) ;; discrete-type := "text" / "image" / "audio" / "video" / ;; "application" / extension-token - (define discrete-type - (lambda (value) - (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)]) - (if val (cdr val) (extension-token value))))) + (define (discrete-type value) + (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)]) + (if val (cdr val) (extension-token value)))) ;; composite-type := "message" / "multipart" / extension-token - (define composite-type - (lambda (value) - (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)]) - (if val (cdr val) (extension-token value))))) + (define (composite-type value) + (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)]) + (if val (cdr val) (extension-token value)))) ;; extension-token := ietf-token / x-token - (define extension-token - (lambda (value) - (or (ietf-token value) - (x-token value)))) + (define (extension-token value) + (or (ietf-token value) + (x-token value))) ;; ietf-token := - (define ietf-token - (lambda (value) - (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)]) - (and ans (cdr ans))))) + (define (ietf-token value) + (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)]) + (and ans (cdr ans)))) ;; Directly from RFC 1700: ;; Type Subtype Description Reference @@ -619,48 +592,43 @@ ;; x-token := - (define x-token - (lambda (value) - (let* ([r #rx"^[xX]-(.*)"] - [h (trim-spaces value)] - [ans (regexp-match r h)]) - (and ans - (token (regexp-replace r h "\\1")) - h)))) + (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))) ;; subtype := extension-token / iana-token - (define subtype - (lambda (value) - (if (not value) - (raise (make-empty-subtype)) - (or (extension-token value) - (iana-token value))))) + (define (subtype value) + (if (not value) + (raise (make-empty-subtype)) + (or (extension-token value) + (iana-token value)))) ;; iana-token := - (define iana-token - (lambda (value) - (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)]) - (and ans (cdr ans))))) + (define (iana-token value) + (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)]) + (and ans (cdr ans)))) ;; parameter := attribute "=" value (define re:parameter (regexp "([^=]+)=(.+)")) - (define parameter - (lambda (par) - (let* ([r re:parameter] - [att (attribute (regexp-replace r par "\\1"))] - [val (value (regexp-replace r par "\\2"))]) - (if (regexp-match r par) - (cons (if att (lowercase att) "???") val) - (cons "???" par))))) + (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)))) ;; value := token / quoted-string - (define value - (lambda (val) - (or (token val) - (quoted-string val) - val))) + (define (value val) + (or (token val) + (quoted-string val) + val)) ;; token := 1* @@ -669,13 +637,12 @@ ;; "/" / "[" / "]" / "?" / "=" ;; ; Must be in quoted-string, ;; ; to use within parameter values - (define token - (lambda (value) - (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")] - [ans (regexp-match tspecials value)]) - (and ans - (string=? value (car ans)) - (car ans))))) + (define (token value) + (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")] + [ans (regexp-match tspecials value)]) + (and ans + (string=? value (car ans)) + (car ans)))) ;; attribute := token ;; ; Matching of attributes @@ -683,11 +650,10 @@ (define attribute token) (define re:quotes (regexp "\"(.+)\"")) - (define quoted-string - (lambda (str) - (let* ([quotes re:quotes] - [ans (regexp-match quotes str)]) - (and ans (regexp-replace quotes str "\\1"))))) + (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 @@ -705,36 +671,35 @@ ;; read-date-parm := "read-date" "=" quoted-date-time ;; ;; size-parm := "size" "=" 1*DIGIT - (define disp-params - (lambda (lst disp) - (let loop ([lst lst]) - (unless (null? lst) - (let* ([p (parameter (trim-all-spaces (car lst)))] - [parm (car p)] - [value (cdr p)]) - (cond [(string=? parm "filename") - (set-disposition-filename! disp value)] - [(string=? parm "creation-date") - (set-disposition-creation! - disp - (disp-quoted-data-time value))] - [(string=? parm "modification-date") - (set-disposition-modification! - disp - (disp-quoted-data-time value))] - [(string=? parm "read-date") - (set-disposition-read! - disp - (disp-quoted-data-time value))] - [(string=? parm "size") - (set-disposition-size! - disp - (string->number value))] - [else - (set-disposition-params! - disp - (append (disposition-params disp) (list p)))]) - (loop (cdr lst))))))) + (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 diff --git a/collects/net/mime-util.ss b/collects/net/mime-util.ss index b0dd1dc68f..0f6efdbf62 100644 --- a/collects/net/mime-util.ss +++ b/collects/net/mime-util.ss @@ -38,92 +38,84 @@ ;; string-index returns the leftmost index in string s ;; that has character c - (define string-index - (lambda (s c) - (let ([n (string-length s)]) - (let loop ([i 0]) - (cond [(>= i n) #f] - [(char=? (string-ref s i) c) i] - [else (loop (+ i 1))]))))) + (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 - (lambda (c s) - (let loop ([s s]) - (if (string=? s "") '() - (let ([i (string-index s c)]) - (if i (cons (substring s 0 i) - (loop (substring s (+ i 1) - (string-length s)))) - (list s))))))) + (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 - (lambda (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)))))))))) + (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 - (lambda (str) - (trim-right (trim-left str)))) + (define (trim-spaces str) + (trim-right (trim-left str))) (define re:left-spaces (regexp "^[ \t\r\n\v]+")) - (define trim-left - (lambda (str) - (regexp-replace re:left-spaces str ""))) + (define (trim-left str) + (regexp-replace re:left-spaces str "")) (define re:right-spaces (regexp "[ \t\r\n\v]+$")) - (define trim-right - (lambda (str) - (regexp-replace re:right-spaces str ""))) + (define (trim-right str) + (regexp-replace re:right-spaces str "")) (define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))")) - (define trim-comments - (lambda (str) - (let ([positions (regexp-match-positions re:comments str)]) - (if positions - (string-append (substring str 0 (caaddr positions)) - (substring str (cdaddr positions) (string-length str))) - str)))) + (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 - (lambda (str) - (let loop ([out ""] [rest str] [size (string-length str)]) - (cond [(zero? size) out] - [else - (loop (string-append out (string - (char-downcase - (string-ref rest 0)))) - (substring rest 1 size) - (sub1 size))])))) + (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 diff --git a/collects/net/nntp-unit.ss b/collects/net/nntp-unit.ss index 8e7e0f953c..aac80a1107 100644 --- a/collects/net/nntp-unit.ss +++ b/collects/net/nntp-unit.ss @@ -35,13 +35,12 @@ ;; - throws an exception - (define signal-error - (lambda (constructor format-string . args) - (lambda exn-args - (raise (apply constructor - (string->immutable-string (apply format format-string args)) - (current-continuation-marks) - exn-args))))) + (define (signal-error constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (string->immutable-string (apply format format-string args)) + (current-continuation-marks) + exn-args)))) ;; default-nntpd-port-number : ;; number @@ -80,120 +79,112 @@ ;; close-communicator : ;; communicator -> () - (define close-communicator - (lambda (communicator) - (close-input-port (communicator-receiver communicator)) - (close-output-port (communicator-sender communicator)))) + (define (close-communicator communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator))) ;; disconnect-from-server : ;; communicator -> () - (define disconnect-from-server - (lambda (communicator) - (send-to-server communicator "QUIT") - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(205) - (close-communicator communicator)] - [else - ((signal-error make-unexpected-response - "unexpected dis-connect response: ~s ~s" - code response) - code response)])))) + (define (disconnect-from-server communicator) + (send-to-server communicator "QUIT") + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(205) + (close-communicator communicator)] + [else + ((signal-error make-unexpected-response + "unexpected dis-connect response: ~s ~s" + code response) + code response)]))) ;; authenticate-user : ;; communicator x user-name x password -> () ;; the password is not used if the server does not ask for it. - (define authenticate-user - (lambda (communicator user password) - (define (reject code response) - ((signal-error make-authentication-rejected - "authentication rejected (~s ~s)" - code response))) - (define (unexpected code response) - ((signal-error make-unexpected-response - "unexpected response for authentication: ~s ~s" - code response) - code response)) - (send-to-server communicator "AUTHINFO USER ~a" user) - (let-values ([(code response) (get-single-line-response communicator)]) - (case code - [(281) (void)] ; server doesn't ask for a password - [(381) - (send-to-server communicator "AUTHINFO PASS ~a" password) - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(281) (void)] ; done - [(502) (reject code response)] - [else (unexpected code response)]))] - [(502) (reject code response)] - [else (reject code response) - (unexpected code response)])))) + (define (authenticate-user communicator user password) + (define (reject code response) + ((signal-error make-authentication-rejected + "authentication rejected (~s ~s)" + code response))) + (define (unexpected code response) + ((signal-error make-unexpected-response + "unexpected response for authentication: ~s ~s" + code response) + code response)) + (send-to-server communicator "AUTHINFO USER ~a" user) + (let-values ([(code response) (get-single-line-response communicator)]) + (case code + [(281) (void)] ; server doesn't ask for a password + [(381) + (send-to-server communicator "AUTHINFO PASS ~a" password) + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(281) (void)] ; done + [(502) (reject code response)] + [else (unexpected code response)]))] + [(502) (reject code response)] + [else (reject code response) + (unexpected code response)]))) ;; send-to-server : ;; communicator x format-string x list (values) -> () - (define send-to-server - (lambda (communicator message-template . rest) - (let ([sender (communicator-sender communicator)]) - (apply fprintf sender - (string-append message-template "\r\n") - rest) - (flush-output sender)))) + (define (send-to-server communicator message-template . rest) + (let ([sender (communicator-sender communicator)]) + (apply fprintf sender + (string-append message-template "\r\n") + rest) + (flush-output sender))) ;; parse-status-line : ;; string -> number x string - (define parse-status-line - (lambda (line) - (if (eof-object? line) - ((signal-error make-bad-status-line "eof instead of a status line") - line) - (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line) - ((signal-error make-bad-status-line - "malformed status line: ~s" line) - line)))]) - (values (string->number (car match)) - (cadr match)))))) + (define (parse-status-line line) + (if (eof-object? line) + ((signal-error make-bad-status-line "eof instead of a status line") + line) + (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line) + ((signal-error make-bad-status-line + "malformed status line: ~s" line) + line)))]) + (values (string->number (car match)) + (cadr match))))) ;; get-one-line-from-server : ;; iport -> string - (define get-one-line-from-server - (lambda (server->client-port) - (read-line server->client-port 'return-linefeed))) + (define (get-one-line-from-server server->client-port) + (read-line server->client-port 'return-linefeed)) ;; get-single-line-response : ;; communicator -> number x string - (define get-single-line-response - (lambda (communicator) - (let ([receiver (communicator-receiver communicator)]) - (let ([status-line (get-one-line-from-server receiver)]) - (parse-status-line status-line))))) + (define (get-single-line-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)]) + (parse-status-line status-line))) ;; get-rest-of-multi-line-response : ;; communicator -> list (string) - (define get-rest-of-multi-line-response - (lambda (communicator) - (let ([receiver (communicator-receiver communicator)]) - (let loop () - (let ([l (get-one-line-from-server receiver)]) - (cond - [(eof-object? l) - ((signal-error make-premature-close - "port prematurely closed during multi-line response") - communicator)] - [(string=? l ".") - '()] - [(string=? l "..") - (cons "." (loop))] - [else - (cons l (loop))])))))) + (define (get-rest-of-multi-line-response communicator) + (let ([receiver (communicator-receiver communicator)]) + (let loop () + (let ([l (get-one-line-from-server receiver)]) + (cond + [(eof-object? l) + ((signal-error make-premature-close + "port prematurely closed during multi-line response") + communicator)] + [(string=? l ".") + '()] + [(string=? l "..") + (cons "." (loop))] + [else + (cons l (loop))]))))) ;; get-multi-line-response : ;; communicator -> number x string x list (string) @@ -201,13 +192,12 @@ ;; -- The returned values are the status code, the rest of the status ;; response line, and the remaining lines. - (define get-multi-line-response - (lambda (communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)]) - (let-values ([(code rest-of-line) - (parse-status-line status-line)]) - (values code rest-of-line (get-rest-of-multi-line-response)))))) + (define (get-multi-line-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)]) + (let-values ([(code rest-of-line) + (parse-status-line status-line)]) + (values code rest-of-line (get-rest-of-multi-line-response))))) ;; open-news-group : ;; communicator x string -> number x number x number @@ -215,66 +205,64 @@ ;; -- The returned values are the number of articles, the first ;; article number, and the last article number for that group. - (define open-news-group - (lambda (communicator group-name) - (send-to-server communicator "GROUP ~a" group-name) - (let-values ([(code rest-of-line) - (get-single-line-response communicator)]) - (case code - [(211) - (let ([match (map string->number - (cdr - (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) - ((signal-error make-bad-newsgroup-line - "malformed newsgroup open response: ~s" - rest-of-line) - rest-of-line))))]) - (let ([number-of-articles (car match)] - [first-article-number (cadr match)] - [last-article-number (caddr match)]) - (values number-of-articles - first-article-number - last-article-number)))] - [(411) - ((signal-error make-non-existent-group - "group ~s does not exist on server ~s" - group-name (communicator-server communicator)) - group-name)] - [else - ((signal-error make-unexpected-response - "unexpected group opening response: ~s" code) - code rest-of-line)])))) + (define (open-news-group communicator group-name) + (send-to-server communicator "GROUP ~a" group-name) + (let-values ([(code rest-of-line) + (get-single-line-response communicator)]) + (case code + [(211) + (let ([match (map string->number + (cdr + (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) + ((signal-error make-bad-newsgroup-line + "malformed newsgroup open response: ~s" + rest-of-line) + rest-of-line))))]) + (let ([number-of-articles (car match)] + [first-article-number (cadr match)] + [last-article-number (caddr match)]) + (values number-of-articles + first-article-number + last-article-number)))] + [(411) + ((signal-error make-non-existent-group + "group ~s does not exist on server ~s" + group-name (communicator-server communicator)) + group-name)] + [else + ((signal-error make-unexpected-response + "unexpected group opening response: ~s" code) + code rest-of-line)]))) ;; generic-message-command : ;; string x number -> communicator x (number U string) -> list (string) - (define generic-message-command - (lambda (command ok-code) - (lambda (communicator message-index) - (send-to-server communicator (string-append command " ~a") - (if (number? message-index) - (number->string message-index) - message-index)) - (let-values ([(code response) - (get-single-line-response communicator)]) - (if (= code ok-code) - (get-rest-of-multi-line-response communicator) - (case code - [(423) - ((signal-error make-article-not-in-group - "article id ~s not in group" message-index) - message-index)] - [(412) - ((signal-error make-no-group-selected - "no group selected"))] - [(430) - ((signal-error make-article-not-found - "no article id ~s found" message-index) - message-index)] - [else - ((signal-error make-unexpected-response - "unexpected message access response: ~s" code) - code response)])))))) + (define (generic-message-command command ok-code) + (lambda (communicator message-index) + (send-to-server communicator (string-append command " ~a") + (if (number? message-index) + (number->string message-index) + message-index)) + (let-values ([(code response) + (get-single-line-response communicator)]) + (if (= code ok-code) + (get-rest-of-multi-line-response communicator) + (case code + [(423) + ((signal-error make-article-not-in-group + "article id ~s not in group" message-index) + message-index)] + [(412) + ((signal-error make-no-group-selected + "no group selected"))] + [(430) + ((signal-error make-article-not-found + "no article id ~s found" message-index) + message-index)] + [else + ((signal-error make-unexpected-response + "unexpected message access response: ~s" code) + code response)]))))) ;; head-of-message : ;; communicator x (number U string) -> list (string) @@ -297,35 +285,33 @@ ;; make-desired-header : ;; string -> desired - (define make-desired-header - (lambda (raw-header) - (regexp - (string-append - "^" - (list->string - (apply append - (map (lambda (c) - (cond - [(char-lower-case? c) - (list #\[ (char-upcase c) c #\])] - [(char-upper-case? c) - (list #\[ c (char-downcase c) #\])] - [else - (list c)])) - (string->list raw-header)))) - ":")))) + (define (make-desired-header raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + [(char-lower-case? c) + (list #\[ (char-upcase c) c #\])] + [(char-upper-case? c) + (list #\[ c (char-downcase c) #\])] + [else + (list c)])) + (string->list raw-header)))) + ":"))) ;; extract-desired-headers : ;; list (string) x list (desired) -> list (string) - (define extract-desired-headers - (lambda (headers desireds) - (let loop ([headers headers]) - (if (null? headers) null - (let ([first (car headers)] - [rest (cdr headers)]) - (if (ormap (lambda (matcher) - (regexp-match matcher first)) - desireds) - (cons first (loop rest)) - (loop rest)))))))) + (define (extract-desired-headers headers desireds) + (let loop ([headers headers]) + (if (null? headers) null + (let ([first (car headers)] + [rest (cdr headers)]) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) + (cons first (loop rest)) + (loop rest))))))) diff --git a/collects/net/pop3-unit.ss b/collects/net/pop3-unit.ss index 6f8a728455..2e9ce64459 100644 --- a/collects/net/pop3-unit.ss +++ b/collects/net/pop3-unit.ss @@ -29,14 +29,13 @@ ;; (exn-args ... -> exn) x format-string x values ... -> ;; exn-args -> () - (define signal-error - (lambda (constructor format-string . args) - (lambda exn-args - (raise (apply constructor - (string->immutable-string - (apply format format-string args)) - (current-continuation-marks) - exn-args))))) + (define (signal-error constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (string->immutable-string + (apply format format-string args)) + (current-continuation-marks) + exn-args)))) ;; signal-malformed-response-error : ;; exn-args -> () @@ -52,11 +51,10 @@ ;; -- signals an error otherwise. - (define confirm-transaction-mode - (lambda (communicator error-message) - (unless (eq? (communicator-state communicator) 'transaction) - ((signal-error make-not-ready-for-transaction error-message) - communicator)))) + (define (confirm-transaction-mode communicator error-message) + (unless (eq? (communicator-state communicator) 'transaction) + ((signal-error make-not-ready-for-transaction error-message) + communicator))) ;; default-pop-port-number : ;; number @@ -98,122 +96,118 @@ ;; -- if authentication succeeds, sets the communicator's state to ;; transaction. - (define authenticate/plain-text - (lambda (username password communicator) - (let ([sender (communicator-sender communicator)]) - (send-to-server communicator "USER ~a" username) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (send-to-server communicator "PASS ~a" password) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (set-communicator-state! communicator 'transaction)] - [(-err? status) - ((signal-error make-password-rejected - "password was rejected"))]))] - [(-err? status) - ((signal-error make-username-rejected - "username was rejected"))]))))) + (define (authenticate/plain-text username password communicator) + (let ([sender (communicator-sender communicator)]) + (send-to-server communicator "USER ~a" username) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (send-to-server communicator "PASS ~a" password) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (set-communicator-state! communicator 'transaction)] + [(-err? status) + ((signal-error make-password-rejected + "password was rejected"))]))] + [(-err? status) + ((signal-error make-username-rejected + "username was rejected"))])))) ;; get-mailbox-status : ;; communicator -> number x number ;; -- returns number of messages and number of octets. - (define get-mailbox-status - (lambda (communicator) - (confirm-transaction-mode - communicator - "cannot get mailbox status unless in transaction mode") - (send-to-server communicator "STAT") - (apply values - (map string->number - (let-values ([(status result) - (get-status-response/match - communicator - #rx"([0-9]+) ([0-9]+)" - #f)]) - result))))) + (define (get-mailbox-status communicator) + (confirm-transaction-mode + communicator + "cannot get mailbox status unless in transaction mode") + (send-to-server communicator "STAT") + (apply values + (map string->number + (let-values ([(status result) + (get-status-response/match + communicator + #rx"([0-9]+) ([0-9]+)" + #f)]) + result)))) ;; get-message/complete : ;; communicator x number -> list (string) x list (string) - (define get-message/complete - (lambda (communicator message) - (confirm-transaction-mode communicator - "cannot get message headers unless in transaction state") - (send-to-server communicator "RETR ~a" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (split-header/body (get-multi-line-response communicator))] - [(-err? status) - ((signal-error make-illegal-message-number - "not given message ~a" message) - communicator message)])))) + (define (get-message/complete communicator message) + (confirm-transaction-mode + communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "RETR ~a" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (split-header/body (get-multi-line-response communicator))] + [(-err? status) + ((signal-error make-illegal-message-number + "not given message ~a" message) + communicator message)]))) ;; get-message/headers : ;; communicator x number -> list (string) - (define get-message/headers - (lambda (communicator message) - (confirm-transaction-mode communicator - "cannot get message headers unless in transaction state") - (send-to-server communicator "TOP ~a 0" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (let-values ([(headers body) - (split-header/body - (get-multi-line-response communicator))]) - headers)] - [(-err? status) - ((signal-error make-not-given-headers - "not given headers to message ~a" message) - communicator message)])))) + (define (get-message/headers communicator message) + (confirm-transaction-mode + communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "TOP ~a 0" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (let-values ([(headers body) + (split-header/body + (get-multi-line-response communicator))]) + headers)] + [(-err? status) + ((signal-error make-not-given-headers + "not given headers to message ~a" message) + communicator message)]))) ;; get-message/body : ;; communicator x number -> list (string) - (define get-message/body - (lambda (communicator message) - (let-values ([(headers body) (get-message/complete communicator message)]) - body))) + (define (get-message/body communicator message) + (let-values ([(headers body) (get-message/complete communicator message)]) + body)) ;; split-header/body : ;; list (string) -> list (string) x list (string) ;; -- returns list of headers and list of body lines. - (define split-header/body - (lambda (lines) - (let loop ([lines lines] [header null]) - (if (null? lines) - (values (reverse header) null) - (let ([first (car lines)] - [rest (cdr lines)]) - (if (string=? first "") - (values (reverse header) rest) - (loop rest (cons first header)))))))) + (define (split-header/body lines) + (let loop ([lines lines] [header null]) + (if (null? lines) + (values (reverse header) null) + (let ([first (car lines)] + [rest (cdr lines)]) + (if (string=? first "") + (values (reverse header) rest) + (loop rest (cons first header))))))) ;; delete-message : ;; communicator x number -> () - (define delete-message - (lambda (communicator message) - (confirm-transaction-mode communicator - "cannot delete message unless in transaction state") - (send-to-server communicator "DELE ~a" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(-err? status) - ((signal-error make-cannot-delete-message - "no message numbered ~a available to be deleted" message) - communicator message)] - [(+ok? status) - 'deleted])))) + (define (delete-message communicator message) + (confirm-transaction-mode + communicator + "cannot delete message unless in transaction state") + (send-to-server communicator "DELE ~a" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(-err? status) + ((signal-error make-cannot-delete-message + "no message numbered ~a available to be deleted" message) + communicator message)] + [(+ok? status) + 'deleted]))) ;; regexp for UIDL responses @@ -223,8 +217,9 @@ ;; communicator x number -> string (define (get-unique-id/single communicator message) - (confirm-transaction-mode communicator - "cannot get unique message id unless in transaction state") + (confirm-transaction-mode + communicator + "cannot get unique message id unless in transaction state") (send-to-server communicator "UIDL ~a" message) (let-values ([(status result) (get-status-response/match communicator uidl-regexp ".*")]) @@ -259,43 +254,39 @@ ;; close-communicator : ;; communicator -> () - (define close-communicator - (lambda (communicator) - (close-input-port (communicator-receiver communicator)) - (close-output-port (communicator-sender communicator)))) + (define (close-communicator communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator))) ;; disconnect-from-server : ;; communicator -> () - (define disconnect-from-server - (lambda (communicator) - (send-to-server communicator "QUIT") - (set-communicator-state! communicator 'disconnected) - (let ([response (get-status-response/basic communicator)]) - (close-communicator communicator) - (cond - [(+ok? response) (void)] - [(-err? response) - ((signal-error make-disconnect-not-quiet - "got error status upon disconnect") - communicator)])))) + (define (disconnect-from-server communicator) + (send-to-server communicator "QUIT") + (set-communicator-state! communicator 'disconnected) + (let ([response (get-status-response/basic communicator)]) + (close-communicator communicator) + (cond + [(+ok? response) (void)] + [(-err? response) + ((signal-error make-disconnect-not-quiet + "got error status upon disconnect") + communicator)]))) ;; send-to-server : ;; communicator x format-string x list (values) -> () - (define send-to-server - (lambda (communicator message-template . rest) - (apply fprintf (communicator-sender communicator) - (string-append message-template "\r\n") - rest) - (flush-output (communicator-sender communicator)))) + (define (send-to-server communicator message-template . rest) + (apply fprintf (communicator-sender communicator) + (string-append message-template "\r\n") + rest) + (flush-output (communicator-sender communicator))) ;; get-one-line-from-server : ;; iport -> string - (define get-one-line-from-server - (lambda (server->client-port) - (read-line server->client-port 'return-linefeed))) + (define (get-one-line-from-server server->client-port) + (read-line server->client-port 'return-linefeed)) ;; get-server-status-response : ;; communicator -> server-responses x string @@ -305,17 +296,16 @@ ;; rest of the status response as a string to be used for further ;; parsing, if necessary. - (define get-server-status-response - (lambda (communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)] - [r (regexp-match #rx"^\\+OK(.*)" status-line)]) - (if r - (values (make-+ok) (cadr r)) - (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) - (if r - (values (make--err) (cadr r)) - (signal-malformed-response-error communicator))))))) + (define (get-server-status-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)] + [r (regexp-match #rx"^\\+OK(.*)" status-line)]) + (if r + (values (make-+ok) (cadr r)) + (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) + (if r + (values (make--err) (cadr r)) + (signal-malformed-response-error communicator)))))) ;; get-status-response/basic : ;; communicator -> server-responses @@ -323,11 +313,10 @@ ;; -- when the only thing to determine is whether the response ;; was +OK or -ERR. - (define get-status-response/basic - (lambda (communicator) - (let-values ([(response rest) - (get-server-status-response communicator)]) - response))) + (define (get-status-response/basic communicator) + (let-values ([(response rest) + (get-server-status-response communicator)]) + response)) ;; get-status-response/match : ;; communicator x regexp x regexp -> (status x list (string)) @@ -335,71 +324,67 @@ ;; -- when further parsing of the status response is necessary. ;; Strips off the car of response from regexp-match. - (define get-status-response/match - (lambda (communicator +regexp -regexp) - (let-values ([(response rest) - (get-server-status-response communicator)]) - (if (and +regexp (+ok? response)) - (let ([r (regexp-match +regexp rest)]) + (define (get-status-response/match communicator +regexp -regexp) + (let-values ([(response rest) + (get-server-status-response communicator)]) + (if (and +regexp (+ok? response)) + (let ([r (regexp-match +regexp rest)]) + (if r (values response (cdr r)) + (signal-malformed-response-error communicator))) + (if (and -regexp (-err? response)) + (let ([r (regexp-match -regexp rest)]) (if r (values response (cdr r)) (signal-malformed-response-error communicator))) - (if (and -regexp (-err? response)) - (let ([r (regexp-match -regexp rest)]) - (if r (values response (cdr r)) - (signal-malformed-response-error communicator))) - (signal-malformed-response-error communicator)))))) + (signal-malformed-response-error communicator))))) ;; get-multi-line-response : ;; communicator -> list (string) - (define get-multi-line-response - (lambda (communicator) - (let ([receiver (communicator-receiver communicator)]) - (let loop () - (let ([l (get-one-line-from-server receiver)]) - (cond - [(eof-object? l) - (signal-malformed-response-error communicator)] - [(string=? l ".") - '()] - [(and (> (string-length l) 1) - (char=? (string-ref l 0) #\.)) - (cons (substring l 1 (string-length l)) (loop))] - [else - (cons l (loop))])))))) + (define (get-multi-line-response communicator) + (let ([receiver (communicator-receiver communicator)]) + (let loop () + (let ([l (get-one-line-from-server receiver)]) + (cond + [(eof-object? l) + (signal-malformed-response-error communicator)] + [(string=? l ".") + '()] + [(and (> (string-length l) 1) + (char=? (string-ref l 0) #\.)) + (cons (substring l 1 (string-length l)) (loop))] + [else + (cons l (loop))]))))) ;; make-desired-header : ;; string -> desired - (define make-desired-header - (lambda (raw-header) - (regexp - (string-append - "^" - (list->string - (apply append - (map (lambda (c) - (cond - [(char-lower-case? c) - (list #\[ (char-upcase c) c #\])] - [(char-upper-case? c) - (list #\[ c (char-downcase c) #\])] - [else - (list c)])) - (string->list raw-header)))) - ":")))) + (define (make-desired-header raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + [(char-lower-case? c) + (list #\[ (char-upcase c) c #\])] + [(char-upper-case? c) + (list #\[ c (char-downcase c) #\])] + [else + (list c)])) + (string->list raw-header)))) + ":"))) ;; extract-desired-headers : ;; list (string) x list (desired) -> list (string) - (define extract-desired-headers - (lambda (headers desireds) - (let loop ([headers headers]) - (if (null? headers) null - (let ([first (car headers)] - [rest (cdr headers)]) - (if (ormap (lambda (matcher) - (regexp-match matcher first)) - desireds) - (cons first (loop rest)) - (loop rest)))))))) + (define (extract-desired-headers headers desireds) + (let loop ([headers headers]) + (if (null? headers) null + (let ([first (car headers)] + [rest (cdr headers)]) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) + (cons first (loop rest)) + (loop rest))))))) diff --git a/collects/net/smtp-unit.ss b/collects/net/smtp-unit.ss index 8b1220b3d3..553c75e534 100644 --- a/collects/net/smtp-unit.ss +++ b/collects/net/smtp-unit.ss @@ -8,8 +8,6 @@ (define debug-via-stdio? #f) - (define crlf (string #\return #\linefeed)) - (define (log . args) ;; (apply printf args) (void)) @@ -61,7 +59,7 @@ (raise x))]) (check-reply r 220 w) (log "hello\n") - (fprintf w "EHLO ~a~a" (smtp-sending-server) crlf) + (fprintf w "EHLO ~a\r\n" (smtp-sending-server)) (check-reply r 250 w) (when auth-user @@ -74,36 +72,36 @@ (check-reply r 235 w)) (log "from\n") - (fprintf w "MAIL FROM:<~a>~a" sender crlf) + (fprintf w "MAIL FROM:<~a>\r\n" sender) (check-reply r 250 w) (log "to\n") (for-each (lambda (dest) - (fprintf w "RCPT TO:<~a>~a" dest crlf) + (fprintf w "RCPT TO:<~a>\r\n" dest) (check-reply r 250 w)) recipients) (log "header\n") - (fprintf w "DATA~a" crlf) + (fprintf w "DATA\r\n") (check-reply r 354 w) (fprintf w "~a" header) (for-each (lambda (l) (log "body: ~a\n" l) - (fprintf w "~a~a" (protect-line l) crlf)) + (fprintf w "~a\r\n" (protect-line l))) message-lines) ;; After we send the ".", then only break in an emergency ((smtp-sending-end-of-message)) (log "dot\n") - (fprintf w ".~a" crlf) + (fprintf w ".\r\n") (flush-output w) (check-reply r 250 w) (log "quit\n") - (fprintf w "QUIT~a" crlf) + (fprintf w "QUIT\r\n") (check-reply r 221 w) (close-output-port w)