suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

more formatting etc

Browse Source 
svn: r5048
This commit is contained in:
Eli Barzilay 2006-12-06 21:44:21 +00:00
parent f17f7bc479
commit 680c0f419a
5 changed files with 741 additions and 815 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -146,8 +146,7 @@
;; get-headers : input-port -> string ;; get-headers : input-port -> string
;; returns the header part of a message/part conforming to rfc822, and ;; returns the header part of a message/part conforming to rfc822, and
;; rfc2045. ;; rfc2045.
(define get-headers (define (get-headers in)
(lambda (in)
(let loop ([headers ""] [ln (read-line in 'any)]) (let loop ([headers ""] [ln (read-line in 'any)])
(cond [(eof-object? ln) (cond [(eof-object? ln)
;; (raise (make-unexpected-termination "eof reached! while parsing headers")) ;; (raise (make-unexpected-termination "eof reached! while parsing headers"))
@ -163,10 +162,9 @@
;; the CRLF ending the last field (header) as the first ;; the CRLF ending the last field (header) as the first
;; CRLF of the null line. ;; CRLF of the null line.
(loop (string-append headers ln CRLF) (loop (string-append headers ln CRLF)
(read-line in 'any))])))) (read-line in 'any))])))
(define make-default-disposition (define (make-default-disposition)
(lambda ()
(make-disposition (make-disposition
'inline ;; type 'inline ;; type
"" ;; filename "" ;; filename
@ -175,10 +173,9 @@
#f ;; read #f ;; read
#f ;; size #f ;; size
null ;; params null ;; params
))) ))
(define make-default-entity (define (make-default-entity)
(lambda ()
(make-entity (make-entity
'text ;; type 'text ;; type
'plain ;; subtype 'plain ;; subtype
@ -192,14 +189,12 @@
null ;; fields null ;; fields
null ;; parts null ;; parts
null ;; body null ;; body
))) ))
(define make-default-message (define (make-default-message)
(lambda () (make-message 1.0 (make-default-entity) null))
(make-message 1.0 (make-default-entity) null)))
(define mime-decode (define (mime-decode entity input)
(lambda (entity input)
(set-entity-body! (set-entity-body!
entity entity
(case (entity-encoding entity) (case (entity-encoding entity)
@ -211,7 +206,7 @@
(base64-decode-stream input output))] (base64-decode-stream input output))]
[else ;; 7bit, 8bit, binary [else ;; 7bit, 8bit, binary
(lambda (output) (lambda (output)
(copy-port input output))])))) (copy-port input output))])))
(define mime-analyze (define mime-analyze
(opt-lambda (input (part #f)) (opt-lambda (input (part #f))
@ -245,11 +240,10 @@
;; return mime structure ;; return mime structure
msg))) msg)))
(define entity-boundary (define (entity-boundary entity)
(lambda (entity)
(let* ([params (entity-params entity)] (let* ([params (entity-params entity)]
[ans (assoc "boundary" params)]) [ans (assoc "boundary" params)])
(and ans (cdr ans))))) (and ans (cdr ans))))
;; ************************************************* ;; *************************************************
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183 ;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
@ -261,8 +255,7 @@
;; close-delimiter transport-padding ;; close-delimiter transport-padding
;; [CRLF epilogue] ;; [CRLF epilogue]
;; Returns a list of input ports, each one containing the correspongind part. ;; Returns a list of input ports, each one containing the correspongind part.
(define multipart-body (define (multipart-body input boundary)
(lambda (input boundary)
(let* ([make-re (lambda (prefix) (let* ([make-re (lambda (prefix)
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))] (regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
[re (make-re "\r\n")]) [re (make-re "\r\n")])
@ -290,9 +283,9 @@
(eat-part)) (eat-part))
(let loop () (let loop ()
(let-values ([(part close? eof?) (eat-part)]) (let-values ([(part close? eof?) (eat-part)])
(cond (close? (list part)) (cond [close? (list part)]
(eof? (list part)) [eof? (list part)]
(else (cons part (loop)))))))))) [else (cons part (loop))]))))))
;; MIME-message-headers := entity-headers ;; MIME-message-headers := entity-headers
;; fields ;; fields
@ -300,11 +293,10 @@
;; ; The ordering of the header ;; ; The ordering of the header
;; ; fields implied by this BNF ;; ; fields implied by this BNF
;; ; definition should be ignored. ;; ; definition should be ignored.
(define MIME-message-headers (define (MIME-message-headers headers)
(lambda (headers)
(let ([message (make-default-message)]) (let ([message (make-default-message)])
(entity-headers headers message #t) (entity-headers headers message #t)
message))) message))
;; MIME-part-headers := entity-headers ;; MIME-part-headers := entity-headers
;; [ fields ] ;; [ fields ]
@ -314,19 +306,17 @@
;; ; The ordering of the header ;; ; The ordering of the header
;; ; fields implied by this BNF ;; ; fields implied by this BNF
;; ; definition should be ignored. ;; ; definition should be ignored.
(define MIME-part-headers (define (MIME-part-headers headers)
(lambda (headers)
(let ([message (make-default-message)]) (let ([message (make-default-message)])
(entity-headers headers message #f) (entity-headers headers message #f)
message))) message))
;; entity-headers := [ content CRLF ] ;; entity-headers := [ content CRLF ]
;; [ encoding CRLF ] ;; [ encoding CRLF ]
;; [ id CRLF ] ;; [ id CRLF ]
;; [ description CRLF ] ;; [ description CRLF ]
;; *( MIME-extension-field CRLF ) ;; *( MIME-extension-field CRLF )
(define entity-headers (define (entity-headers headers message version?)
(lambda (headers message version?)
(let ([entity (message-entity message)]) (let ([entity (message-entity message)])
(let-values ([(mime non-mime) (get-fields headers)]) (let-values ([(mime non-mime) (get-fields headers)])
(let loop ([fields mime]) (let loop ([fields mime])
@ -347,10 +337,9 @@
;; the fields field of the message struct: ;; the fields field of the message struct:
(set-message-fields! message non-mime) (set-message-fields! message non-mime)
;; Return message ;; Return message
message)))) message)))
(define get-fields (define (get-fields headers)
(lambda (headers)
(let ([mime null] [non-mime null]) (let ([mime null] [non-mime null])
(letrec ([store-field (letrec ([store-field
(lambda (f) (lambda (f)
@ -362,15 +351,14 @@
(for-each (lambda (p) (for-each (lambda (p)
(store-field (format "~a: ~a" (car p) (cdr p)))) (store-field (format "~a: ~a" (car p) (cdr p))))
fields)) fields))
(values mime non-mime))))) (values mime non-mime))))
(define re:content (regexp (format "^~a" (regexp-quote "content-" #f)))) (define re:content (regexp (format "^~a" (regexp-quote "content-" #f))))
(define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f)))) (define re:mime (regexp (format "^~a:" (regexp-quote "mime-version" #f))))
(define mime-header? (define (mime-header? h)
(lambda (h) (or (regexp-match? re:content h)
(or (regexp-match re:content h) (regexp-match? re:mime h)))
(regexp-match re:mime h))))
;;; Headers ;;; Headers
;;; Content-type follows this BNF syntax: ;;; Content-type follows this BNF syntax:
@ -380,8 +368,7 @@
;; ; is ALWAYS case-insensitive. ;; ; is ALWAYS case-insensitive.
(define re:content-type (define re:content-type
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f)))) (regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
(define content (define (content header entity)
(lambda (header entity)
(let* ([params (string-tokenizer #\; header)] (let* ([params (string-tokenizer #\; header)]
[one re:content-type] [one re:content-type]
[h (trim-all-spaces (car params))] [h (trim-all-spaces (car params))]
@ -409,15 +396,14 @@
[else [else
(warning "Invalid parameter for Content-Type: `~a'" (car p)) (warning "Invalid parameter for Content-Type: `~a'" (car p))
;; go on... ;; go on...
(loop (cdr p) ans)]))])))))))) (loop (cdr p) ans)]))])))))))
;; From rfc2183 Content-Disposition ;; From rfc2183 Content-Disposition
;; disposition := "Content-Disposition" ":" ;; disposition := "Content-Disposition" ":"
;; disposition-type ;; disposition-type
;; *(";" disposition-parm) ;; *(";" disposition-parm)
(define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f)))) (define re:content-disposition (regexp (format "^~a:(.+)$" (regexp-quote "content-disposition" #f))))
(define dispositione (define (dispositione header entity)
(lambda (header entity)
(let* ([params (string-tokenizer #\; header)] (let* ([params (string-tokenizer #\; header)]
[reg re:content-disposition] [reg re:content-disposition]
[h (trim-all-spaces (car params))] [h (trim-all-spaces (car params))]
@ -427,56 +413,52 @@
(set-disposition-type! (set-disposition-type!
disp-struct disp-struct
(disp-type (regexp-replace reg h "\\1"))) (disp-type (regexp-replace reg h "\\1")))
(disp-params (cdr params) disp-struct))))) (disp-params (cdr params) disp-struct))))
;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT ;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT
(define re:mime-version (define re:mime-version
(regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f)))) (regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
(define version (define (version header message)
(lambda (header message)
(let* ([reg re:mime-version] (let* ([reg re:mime-version]
[h (trim-all-spaces header)] [h (trim-all-spaces header)]
[target (regexp-match reg h)]) [target (regexp-match reg h)])
(and target (and target
(set-message-version! (set-message-version!
message message
(string->number (regexp-replace reg h "\\1.\\2"))))))) (string->number (regexp-replace reg h "\\1.\\2"))))))
;; description := "Content-Description" ":" *text ;; description := "Content-Description" ":" *text
(define re:content-description (define re:content-description
(regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f)))) (regexp (format "^~a:[ \t\r\n]*(.*)$" (regexp-quote "content-description" #f))))
(define description (define (description header entity)
(lambda (header entity)
(let* ([reg re:content-description] (let* ([reg re:content-description]
[target (regexp-match reg header)]) [target (regexp-match reg header)])
(and target (and target
(set-entity-description! (set-entity-description!
entity entity
(trim-spaces (regexp-replace reg header "\\1"))))))) (trim-spaces (regexp-replace reg header "\\1"))))))
;; encoding := "Content-Transfer-Encoding" ":" mechanism ;; encoding := "Content-Transfer-Encoding" ":" mechanism
(define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f)))) (define re:content-transfer-encoding (regexp (format "^~a:(.+)$" (regexp-quote "content-transfer-encoding" #f))))
(define encoding (define (encoding header entity)
(lambda (header entity)
(let* ([reg re:content-transfer-encoding] (let* ([reg re:content-transfer-encoding]
[h (trim-all-spaces header)] [h (trim-all-spaces header)]
[target (regexp-match reg h)]) [target (regexp-match reg h)])
(and target (and target
(set-entity-encoding! (set-entity-encoding!
entity entity
(mechanism (regexp-replace reg h "\\1"))))))) (mechanism (regexp-replace reg h "\\1"))))))
;; id := "Content-ID" ":" msg-id ;; id := "Content-ID" ":" msg-id
(define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f)))) (define re:content-id (regexp (format "^~a:(.+)$" (regexp-quote "content-id" #f))))
(define id (define (id header entity)
(lambda (header entity)
(let* ([reg re:content-id] (let* ([reg re:content-id]
[h (trim-all-spaces header)] [h (trim-all-spaces header)]
[target (regexp-match reg h)]) [target (regexp-match reg h)])
(and target (and target
(set-entity-id! (set-entity-id!
entity entity
(msg-id (regexp-replace reg h "\\1"))))))) (msg-id (regexp-replace reg h "\\1"))))))
;; From rfc822: ;; From rfc822:
;; msg-id = "<" addr-spec ">" ; Unique message id ;; msg-id = "<" addr-spec ">" ; Unique message id
@ -487,32 +469,29 @@
;; sub-domain = domain-ref / domain-literal ;; sub-domain = domain-ref / domain-literal
;; domain-literal = "[" *(dtext / quoted-pair) "]" ;; domain-literal = "[" *(dtext / quoted-pair) "]"
;; domain-ref = atom ; symbolic reference ;; domain-ref = atom ; symbolic reference
(define msg-id (define (msg-id str)
(lambda (str)
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")] (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
[ans (regexp-match r str)]) [ans (regexp-match r str)])
(if ans (if ans
str str
(begin (warning "Invalid msg-id: ~a" str) str))))) (begin (warning "Invalid msg-id: ~a" str) str))))
;; mechanism := "7bit" / "8bit" / "binary" / ;; mechanism := "7bit" / "8bit" / "binary" /
;; "quoted-printable" / "base64" / ;; "quoted-printable" / "base64" /
;; ietf-token / x-token ;; ietf-token / x-token
(define mechanism (define (mechanism mech)
(lambda (mech)
(if (not mech) (if (not mech)
(raise (make-empty-mechanism)) (raise (make-empty-mechanism))
(let ([val (assoc (lowercase mech) mechanism-alist)]) (let ([val (assoc (lowercase mech) mechanism-alist)])
(or (and val (cdr val)) (or (and val (cdr val))
(ietf-token mech) (ietf-token mech)
(x-token mech)))))) (x-token mech)))))
;; MIME-extension-field := <Any RFC 822 header field which ;; MIME-extension-field := <Any RFC 822 header field which
;; begins with the string ;; begins with the string
;; "Content-"> ;; "Content-">
;; ;;
(define MIME-extension-field (define (MIME-extension-field header entity)
(lambda (header entity)
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")] (let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
[target (regexp-match reg header)]) [target (regexp-match reg header)])
(and target (and target
@ -521,50 +500,44 @@
(append (entity-other entity) (append (entity-other entity)
(list (list
(cons (regexp-replace reg header "\\1") (cons (regexp-replace reg header "\\1")
(trim-spaces (regexp-replace reg header "\\2")))))))))) (trim-spaces (regexp-replace reg header "\\2")))))))))
;; type := discrete-type / composite-type ;; type := discrete-type / composite-type
(define type (define (type value)
(lambda (value)
(if (not value) (if (not value)
(raise (make-empty-type)) (raise (make-empty-type))
(or (discrete-type value) (or (discrete-type value)
(composite-type value))))) (composite-type value))))
;; disposition-type := "inline" / "attachment" / extension-token ;; disposition-type := "inline" / "attachment" / extension-token
(define disp-type (define (disp-type value)
(lambda (value)
(if (not value) (if (not value)
(raise (make-empty-disposition-type)) (raise (make-empty-disposition-type))
(let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)]) (let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)])
(if val (cdr val) (extension-token value)))))) (if val (cdr val) (extension-token value)))))
;; discrete-type := "text" / "image" / "audio" / "video" / ;; discrete-type := "text" / "image" / "audio" / "video" /
;; "application" / extension-token ;; "application" / extension-token
(define discrete-type (define (discrete-type value)
(lambda (value)
(let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)]) (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)])
(if val (cdr val) (extension-token value))))) (if val (cdr val) (extension-token value))))
;; composite-type := "message" / "multipart" / extension-token ;; composite-type := "message" / "multipart" / extension-token
(define composite-type (define (composite-type value)
(lambda (value)
(let ([val (assoc (lowercase (trim-spaces value)) composite-alist)]) (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)])
(if val (cdr val) (extension-token value))))) (if val (cdr val) (extension-token value))))
;; extension-token := ietf-token / x-token ;; extension-token := ietf-token / x-token
(define extension-token (define (extension-token value)
(lambda (value)
(or (ietf-token value) (or (ietf-token value)
(x-token value)))) (x-token value)))
;; ietf-token := <An extension token defined by a ;; ietf-token := <An extension token defined by a
;; standards-track RFC and registered ;; standards-track RFC and registered
;; with IANA.> ;; with IANA.>
(define ietf-token (define (ietf-token value)
(lambda (value)
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)]) (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
(and ans (cdr ans))))) (and ans (cdr ans))))
;; Directly from RFC 1700: ;; Directly from RFC 1700:
;; Type Subtype Description Reference ;; Type Subtype Description Reference
@ -619,48 +592,43 @@
;; x-token := <The two characters "X-" or "x-" followed, with ;; x-token := <The two characters "X-" or "x-" followed, with
;; no intervening white space, by any token> ;; no intervening white space, by any token>
(define x-token (define (x-token value)
(lambda (value)
(let* ([r #rx"^[xX]-(.*)"] (let* ([r #rx"^[xX]-(.*)"]
[h (trim-spaces value)] [h (trim-spaces value)]
[ans (regexp-match r h)]) [ans (regexp-match r h)])
(and ans (and ans
(token (regexp-replace r h "\\1")) (token (regexp-replace r h "\\1"))
h)))) h)))
;; subtype := extension-token / iana-token ;; subtype := extension-token / iana-token
(define subtype (define (subtype value)
(lambda (value)
(if (not value) (if (not value)
(raise (make-empty-subtype)) (raise (make-empty-subtype))
(or (extension-token value) (or (extension-token value)
(iana-token value))))) (iana-token value))))
;; iana-token := <A publicly-defined extension token. Tokens ;; iana-token := <A publicly-defined extension token. Tokens
;; of this form must be registered with IANA ;; of this form must be registered with IANA
;; as specified in RFC 2048.> ;; as specified in RFC 2048.>
(define iana-token (define (iana-token value)
(lambda (value)
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)]) (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
(and ans (cdr ans))))) (and ans (cdr ans))))
;; parameter := attribute "=" value ;; parameter := attribute "=" value
(define re:parameter (regexp "([^=]+)=(.+)")) (define re:parameter (regexp "([^=]+)=(.+)"))
(define parameter (define (parameter par)
(lambda (par)
(let* ([r re:parameter] (let* ([r re:parameter]
[att (attribute (regexp-replace r par "\\1"))] [att (attribute (regexp-replace r par "\\1"))]
[val (value (regexp-replace r par "\\2"))]) [val (value (regexp-replace r par "\\2"))])
(if (regexp-match r par) (if (regexp-match r par)
(cons (if att (lowercase att) "???") val) (cons (if att (lowercase att) "???") val)
(cons "???" par))))) (cons "???" par))))
;; value := token / quoted-string ;; value := token / quoted-string
(define value (define (value val)
(lambda (val)
(or (token val) (or (token val)
(quoted-string val) (quoted-string val)
val))) val))
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs, ;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
;; or tspecials> ;; or tspecials>
@ -669,13 +637,12 @@
;; "/" / "[" / "]" / "?" / "=" ;; "/" / "[" / "]" / "?" / "="
;; ; Must be in quoted-string, ;; ; Must be in quoted-string,
;; ; to use within parameter values ;; ; to use within parameter values
(define token (define (token value)
(lambda (value)
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")] (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
[ans (regexp-match tspecials value)]) [ans (regexp-match tspecials value)])
(and ans (and ans
(string=? value (car ans)) (string=? value (car ans))
(car ans))))) (car ans))))
;; attribute := token ;; attribute := token
;; ; Matching of attributes ;; ; Matching of attributes
@ -683,11 +650,10 @@
(define attribute token) (define attribute token)
(define re:quotes (regexp "\"(.+)\"")) (define re:quotes (regexp "\"(.+)\""))
(define quoted-string (define (quoted-string str)
(lambda (str)
(let* ([quotes re:quotes] (let* ([quotes re:quotes]
[ans (regexp-match quotes str)]) [ans (regexp-match quotes str)])
(and ans (regexp-replace quotes str "\\1"))))) (and ans (regexp-replace quotes str "\\1"))))
;; disposition-parm := filename-parm ;; disposition-parm := filename-parm
;; / creation-date-parm ;; / creation-date-parm
@ -705,8 +671,7 @@
;; read-date-parm := "read-date" "=" quoted-date-time ;; read-date-parm := "read-date" "=" quoted-date-time
;; ;;
;; size-parm := "size" "=" 1*DIGIT ;; size-parm := "size" "=" 1*DIGIT
(define disp-params (define (disp-params lst disp)
(lambda (lst disp)
(let loop ([lst lst]) (let loop ([lst lst])
(unless (null? lst) (unless (null? lst)
(let* ([p (parameter (trim-all-spaces (car lst)))] (let* ([p (parameter (trim-all-spaces (car lst)))]
@ -734,7 +699,7 @@
(set-disposition-params! (set-disposition-params!
disp disp
(append (disposition-params disp) (list p)))]) (append (disposition-params disp) (list p)))])
(loop (cdr lst))))))) (loop (cdr lst))))))
;; date-time = [ day "," ] date time ; dd mm yy ;; date-time = [ day "," ] date time ; dd mm yy
;; ; hh:mm:ss zzz ;; ; hh:mm:ss zzz

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

@ -38,30 +38,27 @@
;; string-index returns the leftmost index in string s ;; string-index returns the leftmost index in string s
;; that has character c ;; that has character c
(define string-index (define (string-index s c)
(lambda (s c)
(let ([n (string-length s)]) (let ([n (string-length s)])
(let loop ([i 0]) (let loop ([i 0])
(cond [(>= i n) #f] (cond [(>= i n) #f]
[(char=? (string-ref s i) c) i] [(char=? (string-ref s i) c) i]
[else (loop (+ i 1))]))))) [else (loop (+ i 1))]))))
;; string-tokenizer breaks string s into substrings separated by character c ;; string-tokenizer breaks string s into substrings separated by character c
(define string-tokenizer (define (string-tokenizer c s)
(lambda (c s)
(let loop ([s s]) (let loop ([s s])
(if (string=? s "") '() (if (string=? s "") '()
(let ([i (string-index s c)]) (let ([i (string-index s c)])
(if i (cons (substring s 0 i) (if i (cons (substring s 0 i)
(loop (substring s (+ i 1) (loop (substring s (+ i 1)
(string-length s)))) (string-length s))))
(list s))))))) (list s))))))
;; Trim all spaces, except those in quoted strings. ;; Trim all spaces, except those in quoted strings.
(define re:quote-start (regexp "\"")) (define re:quote-start (regexp "\""))
(define re:space (regexp "[ \t\n\r\v]")) (define re:space (regexp "[ \t\n\r\v]"))
(define trim-all-spaces (define (trim-all-spaces str)
(lambda (str)
;; Break out alternate quoted and unquoted parts. ;; Break out alternate quoted and unquoted parts.
;; Initial and final string are unquoted. ;; Initial and final string are unquoted.
(let-values ([(unquoted quoted) (let-values ([(unquoted quoted)
@ -88,34 +85,29 @@
(list clean) (list clean)
(list* clean (list* clean
(car quoted) (car quoted)
(loop (cdr unquoted) (cdr quoted)))))))))) (loop (cdr unquoted) (cdr quoted)))))))))
;; Only trims left and right spaces: ;; Only trims left and right spaces:
(define trim-spaces (define (trim-spaces str)
(lambda (str) (trim-right (trim-left str)))
(trim-right (trim-left str))))
(define re:left-spaces (regexp "^[ \t\r\n\v]+")) (define re:left-spaces (regexp "^[ \t\r\n\v]+"))
(define trim-left (define (trim-left str)
(lambda (str) (regexp-replace re:left-spaces str ""))
(regexp-replace re:left-spaces str "")))
(define re:right-spaces (regexp "[ \t\r\n\v]+$")) (define re:right-spaces (regexp "[ \t\r\n\v]+$"))
(define trim-right (define (trim-right str)
(lambda (str) (regexp-replace re:right-spaces str ""))
(regexp-replace re:right-spaces str "")))
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))")) (define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define trim-comments (define (trim-comments str)
(lambda (str)
(let ([positions (regexp-match-positions re:comments str)]) (let ([positions (regexp-match-positions re:comments str)])
(if positions (if positions
(string-append (substring str 0 (caaddr positions)) (string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str))) (substring str (cdaddr positions) (string-length str)))
str)))) str)))
(define lowercase (define (lowercase str)
(lambda (str)
(let loop ([out ""] [rest str] [size (string-length str)]) (let loop ([out ""] [rest str] [size (string-length str)])
(cond [(zero? size) out] (cond [(zero? size) out]
[else [else
@ -123,7 +115,7 @@
(char-downcase (char-downcase
(string-ref rest 0)))) (string-ref rest 0))))
(substring rest 1 size) (substring rest 1 size)
(sub1 size))])))) (sub1 size))])))
(define warning (define warning
void void

74
collects/net/nntp-unit.ss
View File

@ -35,13 +35,12 @@
;; - throws an exception ;; - throws an exception
(define signal-error (define (signal-error constructor format-string . args)
(lambda (constructor format-string . args)
(lambda exn-args (lambda exn-args
(raise (apply constructor (raise (apply constructor
(string->immutable-string (apply format format-string args)) (string->immutable-string (apply format format-string args))
(current-continuation-marks) (current-continuation-marks)
exn-args))))) exn-args))))
;; default-nntpd-port-number : ;; default-nntpd-port-number :
;; number ;; number
@ -80,16 +79,14 @@
;; close-communicator : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define close-communicator (define (close-communicator communicator)
(lambda (communicator)
(close-input-port (communicator-receiver communicator)) (close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator)))) (close-output-port (communicator-sender communicator)))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(define disconnect-from-server (define (disconnect-from-server communicator)
(lambda (communicator)
(send-to-server communicator "QUIT") (send-to-server communicator "QUIT")
(let-values ([(code response) (let-values ([(code response)
(get-single-line-response communicator)]) (get-single-line-response communicator)])
@ -100,14 +97,13 @@
((signal-error make-unexpected-response ((signal-error make-unexpected-response
"unexpected dis-connect response: ~s ~s" "unexpected dis-connect response: ~s ~s"
code response) code response)
code response)])))) code response)])))
;; authenticate-user : ;; authenticate-user :
;; communicator x user-name x password -> () ;; communicator x user-name x password -> ()
;; the password is not used if the server does not ask for it. ;; the password is not used if the server does not ask for it.
(define authenticate-user (define (authenticate-user communicator user password)
(lambda (communicator user password)
(define (reject code response) (define (reject code response)
((signal-error make-authentication-rejected ((signal-error make-authentication-rejected
"authentication rejected (~s ~s)" "authentication rejected (~s ~s)"
@ -131,24 +127,22 @@
[else (unexpected code response)]))] [else (unexpected code response)]))]
[(502) (reject code response)] [(502) (reject code response)]
[else (reject code response) [else (reject code response)
(unexpected code response)])))) (unexpected code response)])))
;; send-to-server : ;; send-to-server :
;; communicator x format-string x list (values) -> () ;; communicator x format-string x list (values) -> ()
(define send-to-server (define (send-to-server communicator message-template . rest)
(lambda (communicator message-template . rest)
(let ([sender (communicator-sender communicator)]) (let ([sender (communicator-sender communicator)])
(apply fprintf sender (apply fprintf sender
(string-append message-template "\r\n") (string-append message-template "\r\n")
rest) rest)
(flush-output sender)))) (flush-output sender)))
;; parse-status-line : ;; parse-status-line :
;; string -> number x string ;; string -> number x string
(define parse-status-line (define (parse-status-line line)
(lambda (line)
(if (eof-object? line) (if (eof-object? line)
((signal-error make-bad-status-line "eof instead of a status line") ((signal-error make-bad-status-line "eof instead of a status line")
line) line)
@ -157,29 +151,26 @@
"malformed status line: ~s" line) "malformed status line: ~s" line)
line)))]) line)))])
(values (string->number (car match)) (values (string->number (car match))
(cadr match)))))) (cadr match)))))
;; get-one-line-from-server : ;; get-one-line-from-server :
;; iport -> string ;; iport -> string
(define get-one-line-from-server (define (get-one-line-from-server server->client-port)
(lambda (server->client-port) (read-line server->client-port 'return-linefeed))
(read-line server->client-port 'return-linefeed)))
;; get-single-line-response : ;; get-single-line-response :
;; communicator -> number x string ;; communicator -> number x string
(define get-single-line-response (define (get-single-line-response communicator)
(lambda (communicator) (let* ([receiver (communicator-receiver communicator)]
(let ([receiver (communicator-receiver communicator)]) [status-line (get-one-line-from-server receiver)])
(let ([status-line (get-one-line-from-server receiver)]) (parse-status-line status-line)))
(parse-status-line status-line)))))
;; get-rest-of-multi-line-response : ;; get-rest-of-multi-line-response :
;; communicator -> list (string) ;; communicator -> list (string)
(define get-rest-of-multi-line-response (define (get-rest-of-multi-line-response communicator)
(lambda (communicator)
(let ([receiver (communicator-receiver communicator)]) (let ([receiver (communicator-receiver communicator)])
(let loop () (let loop ()
(let ([l (get-one-line-from-server receiver)]) (let ([l (get-one-line-from-server receiver)])
@ -193,7 +184,7 @@
[(string=? l "..") [(string=? l "..")
(cons "." (loop))] (cons "." (loop))]
[else [else
(cons l (loop))])))))) (cons l (loop))])))))
;; get-multi-line-response : ;; get-multi-line-response :
;; communicator -> number x string x list (string) ;; communicator -> number x string x list (string)
@ -201,13 +192,12 @@
;; -- The returned values are the status code, the rest of the status ;; -- The returned values are the status code, the rest of the status
;; response line, and the remaining lines. ;; response line, and the remaining lines.
(define get-multi-line-response (define (get-multi-line-response communicator)
(lambda (communicator)
(let* ([receiver (communicator-receiver communicator)] (let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)]) [status-line (get-one-line-from-server receiver)])
(let-values ([(code rest-of-line) (let-values ([(code rest-of-line)
(parse-status-line status-line)]) (parse-status-line status-line)])
(values code rest-of-line (get-rest-of-multi-line-response)))))) (values code rest-of-line (get-rest-of-multi-line-response)))))
;; open-news-group : ;; open-news-group :
;; communicator x string -> number x number x number ;; communicator x string -> number x number x number
@ -215,8 +205,7 @@
;; -- The returned values are the number of articles, the first ;; -- The returned values are the number of articles, the first
;; article number, and the last article number for that group. ;; article number, and the last article number for that group.
(define open-news-group (define (open-news-group communicator group-name)
(lambda (communicator group-name)
(send-to-server communicator "GROUP ~a" group-name) (send-to-server communicator "GROUP ~a" group-name)
(let-values ([(code rest-of-line) (let-values ([(code rest-of-line)
(get-single-line-response communicator)]) (get-single-line-response communicator)])
@ -243,13 +232,12 @@
[else [else
((signal-error make-unexpected-response ((signal-error make-unexpected-response
"unexpected group opening response: ~s" code) "unexpected group opening response: ~s" code)
code rest-of-line)])))) code rest-of-line)])))
;; generic-message-command : ;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string) ;; string x number -> communicator x (number U string) -> list (string)
(define generic-message-command (define (generic-message-command command ok-code)
(lambda (command ok-code)
(lambda (communicator message-index) (lambda (communicator message-index)
(send-to-server communicator (string-append command " ~a") (send-to-server communicator (string-append command " ~a")
(if (number? message-index) (if (number? message-index)
@ -274,7 +262,7 @@
[else [else
((signal-error make-unexpected-response ((signal-error make-unexpected-response
"unexpected message access response: ~s" code) "unexpected message access response: ~s" code)
code response)])))))) code response)])))))
;; head-of-message : ;; head-of-message :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
@ -297,8 +285,7 @@
;; make-desired-header : ;; make-desired-header :
;; string -> desired ;; string -> desired
(define make-desired-header (define (make-desired-header raw-header)
(lambda (raw-header)
(regexp (regexp
(string-append (string-append
"^" "^"
@ -313,13 +300,12 @@
[else [else
(list c)])) (list c)]))
(string->list raw-header)))) (string->list raw-header))))
":")))) ":")))
;; extract-desired-headers : ;; extract-desired-headers :
;; list (string) x list (desired) -> list (string) ;; list (string) x list (desired) -> list (string)
(define extract-desired-headers (define (extract-desired-headers headers desireds)
(lambda (headers desireds)
(let loop ([headers headers]) (let loop ([headers headers])
(if (null? headers) null (if (null? headers) null
(let ([first (car headers)] (let ([first (car headers)]
@ -328,4 +314,4 @@
(regexp-match matcher first)) (regexp-match matcher first))
desireds) desireds)
(cons first (loop rest)) (cons first (loop rest))
(loop rest)))))))) (loop rest)))))))

107
collects/net/pop3-unit.ss
View File

@ -29,14 +29,13 @@
;; (exn-args ... -> exn) x format-string x values ... -> ;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> () ;; exn-args -> ()
(define signal-error (define (signal-error constructor format-string . args)
(lambda (constructor format-string . args)
(lambda exn-args (lambda exn-args
(raise (apply constructor (raise (apply constructor
(string->immutable-string (string->immutable-string
(apply format format-string args)) (apply format format-string args))
(current-continuation-marks) (current-continuation-marks)
exn-args))))) exn-args))))
;; signal-malformed-response-error : ;; signal-malformed-response-error :
;; exn-args -> () ;; exn-args -> ()
@ -52,11 +51,10 @@
;; -- signals an error otherwise. ;; -- signals an error otherwise.
(define confirm-transaction-mode (define (confirm-transaction-mode communicator error-message)
(lambda (communicator error-message)
(unless (eq? (communicator-state communicator) 'transaction) (unless (eq? (communicator-state communicator) 'transaction)
((signal-error make-not-ready-for-transaction error-message) ((signal-error make-not-ready-for-transaction error-message)
communicator)))) communicator)))
;; default-pop-port-number : ;; default-pop-port-number :
;; number ;; number
@ -98,8 +96,7 @@
;; -- if authentication succeeds, sets the communicator's state to ;; -- if authentication succeeds, sets the communicator's state to
;; transaction. ;; transaction.
(define authenticate/plain-text (define (authenticate/plain-text username password communicator)
(lambda (username password communicator)
(let ([sender (communicator-sender communicator)]) (let ([sender (communicator-sender communicator)])
(send-to-server communicator "USER ~a" username) (send-to-server communicator "USER ~a" username)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
@ -115,15 +112,14 @@
"password was rejected"))]))] "password was rejected"))]))]
[(-err? status) [(-err? status)
((signal-error make-username-rejected ((signal-error make-username-rejected
"username was rejected"))]))))) "username was rejected"))]))))
;; get-mailbox-status : ;; get-mailbox-status :
;; communicator -> number x number ;; communicator -> number x number
;; -- returns number of messages and number of octets. ;; -- returns number of messages and number of octets.
(define get-mailbox-status (define (get-mailbox-status communicator)
(lambda (communicator)
(confirm-transaction-mode (confirm-transaction-mode
communicator communicator
"cannot get mailbox status unless in transaction mode") "cannot get mailbox status unless in transaction mode")
@ -135,14 +131,14 @@
communicator communicator
#rx"([0-9]+) ([0-9]+)" #rx"([0-9]+) ([0-9]+)"
#f)]) #f)])
result))))) result))))
;; get-message/complete : ;; get-message/complete :
;; communicator x number -> list (string) x list (string) ;; communicator x number -> list (string) x list (string)
(define get-message/complete (define (get-message/complete communicator message)
(lambda (communicator message) (confirm-transaction-mode
(confirm-transaction-mode communicator communicator
"cannot get message headers unless in transaction state") "cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message) (send-to-server communicator "RETR ~a" message)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
@ -152,14 +148,14 @@
[(-err? status) [(-err? status)
((signal-error make-illegal-message-number ((signal-error make-illegal-message-number
"not given message ~a" message) "not given message ~a" message)
communicator message)])))) communicator message)])))
;; get-message/headers : ;; get-message/headers :
;; communicator x number -> list (string) ;; communicator x number -> list (string)
(define get-message/headers (define (get-message/headers communicator message)
(lambda (communicator message) (confirm-transaction-mode
(confirm-transaction-mode communicator communicator
"cannot get message headers unless in transaction state") "cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message) (send-to-server communicator "TOP ~a 0" message)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
@ -172,23 +168,21 @@
[(-err? status) [(-err? status)
((signal-error make-not-given-headers ((signal-error make-not-given-headers
"not given headers to message ~a" message) "not given headers to message ~a" message)
communicator message)])))) communicator message)])))
;; get-message/body : ;; get-message/body :
;; communicator x number -> list (string) ;; communicator x number -> list (string)
(define get-message/body (define (get-message/body communicator message)
(lambda (communicator message)
(let-values ([(headers body) (get-message/complete communicator message)]) (let-values ([(headers body) (get-message/complete communicator message)])
body))) body))
;; split-header/body : ;; split-header/body :
;; list (string) -> list (string) x list (string) ;; list (string) -> list (string) x list (string)
;; -- returns list of headers and list of body lines. ;; -- returns list of headers and list of body lines.
(define split-header/body (define (split-header/body lines)
(lambda (lines)
(let loop ([lines lines] [header null]) (let loop ([lines lines] [header null])
(if (null? lines) (if (null? lines)
(values (reverse header) null) (values (reverse header) null)
@ -196,14 +190,14 @@
[rest (cdr lines)]) [rest (cdr lines)])
(if (string=? first "") (if (string=? first "")
(values (reverse header) rest) (values (reverse header) rest)
(loop rest (cons first header)))))))) (loop rest (cons first header)))))))
;; delete-message : ;; delete-message :
;; communicator x number -> () ;; communicator x number -> ()
(define delete-message (define (delete-message communicator message)
(lambda (communicator message) (confirm-transaction-mode
(confirm-transaction-mode communicator communicator
"cannot delete message unless in transaction state") "cannot delete message unless in transaction state")
(send-to-server communicator "DELE ~a" message) (send-to-server communicator "DELE ~a" message)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
@ -213,7 +207,7 @@
"no message numbered ~a available to be deleted" message) "no message numbered ~a available to be deleted" message)
communicator message)] communicator message)]
[(+ok? status) [(+ok? status)
'deleted])))) 'deleted])))
;; regexp for UIDL responses ;; regexp for UIDL responses
@ -223,7 +217,8 @@
;; communicator x number -> string ;; communicator x number -> string
(define (get-unique-id/single communicator message) (define (get-unique-id/single communicator message)
(confirm-transaction-mode communicator (confirm-transaction-mode
communicator
"cannot get unique message id unless in transaction state") "cannot get unique message id unless in transaction state")
(send-to-server communicator "UIDL ~a" message) (send-to-server communicator "UIDL ~a" message)
(let-values ([(status result) (let-values ([(status result)
@ -259,16 +254,14 @@
;; close-communicator : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define close-communicator (define (close-communicator communicator)
(lambda (communicator)
(close-input-port (communicator-receiver communicator)) (close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator)))) (close-output-port (communicator-sender communicator)))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(define disconnect-from-server (define (disconnect-from-server communicator)
(lambda (communicator)
(send-to-server communicator "QUIT") (send-to-server communicator "QUIT")
(set-communicator-state! communicator 'disconnected) (set-communicator-state! communicator 'disconnected)
(let ([response (get-status-response/basic communicator)]) (let ([response (get-status-response/basic communicator)])
@ -278,24 +271,22 @@
[(-err? response) [(-err? response)
((signal-error make-disconnect-not-quiet ((signal-error make-disconnect-not-quiet
"got error status upon disconnect") "got error status upon disconnect")
communicator)])))) communicator)])))
;; send-to-server : ;; send-to-server :
;; communicator x format-string x list (values) -> () ;; communicator x format-string x list (values) -> ()
(define send-to-server (define (send-to-server communicator message-template . rest)
(lambda (communicator message-template . rest)
(apply fprintf (communicator-sender communicator) (apply fprintf (communicator-sender communicator)
(string-append message-template "\r\n") (string-append message-template "\r\n")
rest) rest)
(flush-output (communicator-sender communicator)))) (flush-output (communicator-sender communicator)))
;; get-one-line-from-server : ;; get-one-line-from-server :
;; iport -> string ;; iport -> string
(define get-one-line-from-server (define (get-one-line-from-server server->client-port)
(lambda (server->client-port) (read-line server->client-port 'return-linefeed))
(read-line server->client-port 'return-linefeed)))
;; get-server-status-response : ;; get-server-status-response :
;; communicator -> server-responses x string ;; communicator -> server-responses x string
@ -305,8 +296,7 @@
;; rest of the status response as a string to be used for further ;; rest of the status response as a string to be used for further
;; parsing, if necessary. ;; parsing, if necessary.
(define get-server-status-response (define (get-server-status-response communicator)
(lambda (communicator)
(let* ([receiver (communicator-receiver communicator)] (let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)] [status-line (get-one-line-from-server receiver)]
[r (regexp-match #rx"^\\+OK(.*)" status-line)]) [r (regexp-match #rx"^\\+OK(.*)" status-line)])
@ -315,7 +305,7 @@
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
(if r (if r
(values (make--err) (cadr r)) (values (make--err) (cadr r))
(signal-malformed-response-error communicator))))))) (signal-malformed-response-error communicator))))))
;; get-status-response/basic : ;; get-status-response/basic :
;; communicator -> server-responses ;; communicator -> server-responses
@ -323,11 +313,10 @@
;; -- when the only thing to determine is whether the response ;; -- when the only thing to determine is whether the response
;; was +OK or -ERR. ;; was +OK or -ERR.
(define get-status-response/basic (define (get-status-response/basic communicator)
(lambda (communicator)
(let-values ([(response rest) (let-values ([(response rest)
(get-server-status-response communicator)]) (get-server-status-response communicator)])
response))) response))
;; get-status-response/match : ;; get-status-response/match :
;; communicator x regexp x regexp -> (status x list (string)) ;; communicator x regexp x regexp -> (status x list (string))
@ -335,8 +324,7 @@
;; -- when further parsing of the status response is necessary. ;; -- when further parsing of the status response is necessary.
;; Strips off the car of response from regexp-match. ;; Strips off the car of response from regexp-match.
(define get-status-response/match (define (get-status-response/match communicator +regexp -regexp)
(lambda (communicator +regexp -regexp)
(let-values ([(response rest) (let-values ([(response rest)
(get-server-status-response communicator)]) (get-server-status-response communicator)])
(if (and +regexp (+ok? response)) (if (and +regexp (+ok? response))
@ -347,13 +335,12 @@
(let ([r (regexp-match -regexp rest)]) (let ([r (regexp-match -regexp rest)])
(if r (values response (cdr r)) (if r (values response (cdr r))
(signal-malformed-response-error communicator))) (signal-malformed-response-error communicator)))
(signal-malformed-response-error communicator)))))) (signal-malformed-response-error communicator)))))
;; get-multi-line-response : ;; get-multi-line-response :
;; communicator -> list (string) ;; communicator -> list (string)
(define get-multi-line-response (define (get-multi-line-response communicator)
(lambda (communicator)
(let ([receiver (communicator-receiver communicator)]) (let ([receiver (communicator-receiver communicator)])
(let loop () (let loop ()
(let ([l (get-one-line-from-server receiver)]) (let ([l (get-one-line-from-server receiver)])
@ -366,13 +353,12 @@
(char=? (string-ref l 0) #\.)) (char=? (string-ref l 0) #\.))
(cons (substring l 1 (string-length l)) (loop))] (cons (substring l 1 (string-length l)) (loop))]
[else [else
(cons l (loop))])))))) (cons l (loop))])))))
;; make-desired-header : ;; make-desired-header :
;; string -> desired ;; string -> desired
(define make-desired-header (define (make-desired-header raw-header)
(lambda (raw-header)
(regexp (regexp
(string-append (string-append
"^" "^"
@ -387,13 +373,12 @@
[else [else
(list c)])) (list c)]))
(string->list raw-header)))) (string->list raw-header))))
":")))) ":")))
;; extract-desired-headers : ;; extract-desired-headers :
;; list (string) x list (desired) -> list (string) ;; list (string) x list (desired) -> list (string)
(define extract-desired-headers (define (extract-desired-headers headers desireds)
(lambda (headers desireds)
(let loop ([headers headers]) (let loop ([headers headers])
(if (null? headers) null (if (null? headers) null
(let ([first (car headers)] (let ([first (car headers)]
@ -402,4 +387,4 @@
(regexp-match matcher first)) (regexp-match matcher first))
desireds) desireds)
(cons first (loop rest)) (cons first (loop rest))
(loop rest)))))))) (loop rest)))))))

16
collects/net/smtp-unit.ss
View File

@ -8,8 +8,6 @@
(define debug-via-stdio? #f) (define debug-via-stdio? #f)
(define crlf (string #\return #\linefeed))
(define (log . args) (define (log . args)
;; (apply printf args) ;; (apply printf args)
(void)) (void))
@ -61,7 +59,7 @@
(raise x))]) (raise x))])
(check-reply r 220 w) (check-reply r 220 w)
(log "hello\n") (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) (check-reply r 250 w)
(when auth-user (when auth-user
@ -74,36 +72,36 @@
(check-reply r 235 w)) (check-reply r 235 w))
(log "from\n") (log "from\n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf) (fprintf w "MAIL FROM:<~a>\r\n" sender)
(check-reply r 250 w) (check-reply r 250 w)
(log "to\n") (log "to\n")
(for-each (for-each
(lambda (dest) (lambda (dest)
(fprintf w "RCPT TO:<~a>~a" dest crlf) (fprintf w "RCPT TO:<~a>\r\n" dest)
(check-reply r 250 w)) (check-reply r 250 w))
recipients) recipients)
(log "header\n") (log "header\n")
(fprintf w "DATA~a" crlf) (fprintf w "DATA\r\n")
(check-reply r 354 w) (check-reply r 354 w)
(fprintf w "~a" header) (fprintf w "~a" header)
(for-each (for-each
(lambda (l) (lambda (l)
(log "body: ~a\n" l) (log "body: ~a\n" l)
(fprintf w "~a~a" (protect-line l) crlf)) (fprintf w "~a\r\n" (protect-line l)))
message-lines) message-lines)
;; After we send the ".", then only break in an emergency ;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message)) ((smtp-sending-end-of-message))
(log "dot\n") (log "dot\n")
(fprintf w ".~a" crlf) (fprintf w ".\r\n")
(flush-output w) (flush-output w)
(check-reply r 250 w) (check-reply r 250 w)
(log "quit\n") (log "quit\n")
(fprintf w "QUIT~a" crlf) (fprintf w "QUIT\r\n")
(check-reply r 221 w) (check-reply r 221 w)
(close-output-port w) (close-output-port w)