more formatting etc
svn: r5048
This commit is contained in:
Eli Barzilay
parent
f17f7bc479
commit
680c0f419a
|
|
@ -146,8 +146,7 @@
|
|||
;; get-headers : input-port -> string
|
||||
;; returns the header part of a message/part conforming to rfc822, and
|
||||
;; rfc2045.
|
||||
(define get-headers
|
||||
(lambda (in)
|
||||
(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"))
|
||||
|
|
@ -163,10 +162,9 @@
|
|||
;; 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))]))))
|
||||
(read-line in 'any))])))
|
||||
|
||||
(define make-default-disposition
|
||||
(lambda ()
|
||||
(define (make-default-disposition)
|
||||
(make-disposition
|
||||
'inline ;; type
|
||||
"" ;; filename
|
||||
|
|
@ -175,10 +173,9 @@
|
|||
#f ;; read
|
||||
#f ;; size
|
||||
null ;; params
|
||||
)))
|
||||
))
|
||||
|
||||
(define make-default-entity
|
||||
(lambda ()
|
||||
(define (make-default-entity)
|
||||
(make-entity
|
||||
'text ;; type
|
||||
'plain ;; subtype
|
||||
|
|
@ -192,14 +189,12 @@
|
|||
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)
|
||||
(define (mime-decode entity input)
|
||||
(set-entity-body!
|
||||
entity
|
||||
(case (entity-encoding entity)
|
||||
|
|
@ -211,7 +206,7 @@
|
|||
(base64-decode-stream input output))]
|
||||
[else ;; 7bit, 8bit, binary
|
||||
(lambda (output)
|
||||
(copy-port input 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)
|
||||
(define (entity-boundary entity)
|
||||
(let* ([params (entity-params entity)]
|
||||
[ans (assoc "boundary" params)])
|
||||
(and ans (cdr ans)))))
|
||||
(and ans (cdr ans))))
|
||||
|
||||
;; *************************************************
|
||||
;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183
|
||||
|
|
@ -261,8 +255,7 @@
|
|||
;; close-delimiter transport-padding
|
||||
;; [CRLF epilogue]
|
||||
;; Returns a list of input ports, each one containing the correspongind part.
|
||||
(define multipart-body
|
||||
(lambda (input boundary)
|
||||
(define (multipart-body input boundary)
|
||||
(let* ([make-re (lambda (prefix)
|
||||
(regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))]
|
||||
[re (make-re "\r\n")])
|
||||
|
|
@ -290,9 +283,9 @@
|
|||
(eat-part))
|
||||
(let loop ()
|
||||
(let-values ([(part close? eof?) (eat-part)])
|
||||
(cond (close? (list part))
|
||||
(eof? (list part))
|
||||
(else (cons part (loop))))))))))
|
||||
(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)
|
||||
(define (MIME-message-headers headers)
|
||||
(let ([message (make-default-message)])
|
||||
(entity-headers headers message #t)
|
||||
message)))
|
||||
message))
|
||||
|
||||
;; MIME-part-headers := entity-headers
|
||||
;; [ fields ]
|
||||
|
|
@ -314,19 +306,17 @@
|
|||
;; ; The ordering of the header
|
||||
;; ; fields implied by this BNF
|
||||
;; ; definition should be ignored.
|
||||
(define MIME-part-headers
|
||||
(lambda (headers)
|
||||
(define (MIME-part-headers headers)
|
||||
(let ([message (make-default-message)])
|
||||
(entity-headers headers message #f)
|
||||
message)))
|
||||
message))
|
||||
|
||||
;; entity-headers := [ content CRLF ]
|
||||
;; [ encoding CRLF ]
|
||||
;; [ id CRLF ]
|
||||
;; [ description CRLF ]
|
||||
;; *( MIME-extension-field CRLF )
|
||||
(define entity-headers
|
||||
(lambda (headers message version?)
|
||||
(define (entity-headers headers message version?)
|
||||
(let ([entity (message-entity message)])
|
||||
(let-values ([(mime non-mime) (get-fields headers)])
|
||||
(let loop ([fields mime])
|
||||
|
|
@ -347,10 +337,9 @@
|
|||
;; the fields field of the message struct:
|
||||
(set-message-fields! message non-mime)
|
||||
;; Return message
|
||||
message))))
|
||||
message)))
|
||||
|
||||
(define get-fields
|
||||
(lambda (headers)
|
||||
(define (get-fields headers)
|
||||
(let ([mime null] [non-mime null])
|
||||
(letrec ([store-field
|
||||
(lambda (f)
|
||||
|
|
@ -362,15 +351,14 @@
|
|||
(for-each (lambda (p)
|
||||
(store-field (format "~a: ~a" (car p) (cdr p))))
|
||||
fields))
|
||||
(values mime non-mime)))))
|
||||
(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,8 +368,7 @@
|
|||
;; ; is ALWAYS case-insensitive.
|
||||
(define re:content-type
|
||||
(regexp (format "^~a:([^/]+)/([^/]+)$" (regexp-quote "content-type" #f))))
|
||||
(define content
|
||||
(lambda (header entity)
|
||||
(define (content header entity)
|
||||
(let* ([params (string-tokenizer #\; header)]
|
||||
[one re:content-type]
|
||||
[h (trim-all-spaces (car params))]
|
||||
|
|
@ -409,15 +396,14 @@
|
|||
[else
|
||||
(warning "Invalid parameter for Content-Type: `~a'" (car p))
|
||||
;; go on...
|
||||
(loop (cdr p) ans)]))]))))))))
|
||||
(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)
|
||||
(define (dispositione header entity)
|
||||
(let* ([params (string-tokenizer #\; header)]
|
||||
[reg re:content-disposition]
|
||||
[h (trim-all-spaces (car params))]
|
||||
|
|
@ -427,56 +413,52 @@
|
|||
(set-disposition-type!
|
||||
disp-struct
|
||||
(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
|
||||
(define re:mime-version
|
||||
(regexp (format "^~a:([0-9]+)\\.([0-9]+)$" (regexp-quote "MIME-Version" #f))))
|
||||
(define version
|
||||
(lambda (header message)
|
||||
(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")))))))
|
||||
(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)
|
||||
(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")))))))
|
||||
(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)
|
||||
(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")))))))
|
||||
(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)
|
||||
(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")))))))
|
||||
(msg-id (regexp-replace reg h "\\1"))))))
|
||||
|
||||
;; From rfc822:
|
||||
;; msg-id = "<" addr-spec ">" ; Unique message id
|
||||
|
|
@ -487,32 +469,29 @@
|
|||
;; sub-domain = domain-ref / domain-literal
|
||||
;; domain-literal = "[" *(dtext / quoted-pair) "]"
|
||||
;; domain-ref = atom ; symbolic reference
|
||||
(define msg-id
|
||||
(lambda (str)
|
||||
(define (msg-id str)
|
||||
(let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")]
|
||||
[ans (regexp-match r str)])
|
||||
(if ans
|
||||
str
|
||||
(begin (warning "Invalid msg-id: ~a" str) str)))))
|
||||
(begin (warning "Invalid msg-id: ~a" str) str))))
|
||||
|
||||
;; mechanism := "7bit" / "8bit" / "binary" /
|
||||
;; "quoted-printable" / "base64" /
|
||||
;; ietf-token / x-token
|
||||
(define mechanism
|
||||
(lambda (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))))))
|
||||
(x-token mech)))))
|
||||
|
||||
;; MIME-extension-field := <Any RFC 822 header field which
|
||||
;; begins with the string
|
||||
;; "Content-">
|
||||
;;
|
||||
(define MIME-extension-field
|
||||
(lambda (header entity)
|
||||
(define (MIME-extension-field header entity)
|
||||
(let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")]
|
||||
[target (regexp-match reg header)])
|
||||
(and target
|
||||
|
|
@ -521,50 +500,44 @@
|
|||
(append (entity-other entity)
|
||||
(list
|
||||
(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
|
||||
(define type
|
||||
(lambda (value)
|
||||
(define (type value)
|
||||
(if (not value)
|
||||
(raise (make-empty-type))
|
||||
(or (discrete-type value)
|
||||
(composite-type value)))))
|
||||
(composite-type value))))
|
||||
|
||||
;; disposition-type := "inline" / "attachment" / extension-token
|
||||
(define disp-type
|
||||
(lambda (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))))))
|
||||
(if val (cdr val) (extension-token value)))))
|
||||
|
||||
;; discrete-type := "text" / "image" / "audio" / "video" /
|
||||
;; "application" / extension-token
|
||||
(define discrete-type
|
||||
(lambda (value)
|
||||
(define (discrete-type value)
|
||||
(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
|
||||
(define composite-type
|
||||
(lambda (value)
|
||||
(define (composite-type value)
|
||||
(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
|
||||
(define extension-token
|
||||
(lambda (value)
|
||||
(define (extension-token value)
|
||||
(or (ietf-token value)
|
||||
(x-token value))))
|
||||
(x-token value)))
|
||||
|
||||
;; ietf-token := <An extension token defined by a
|
||||
;; standards-track RFC and registered
|
||||
;; with IANA.>
|
||||
(define ietf-token
|
||||
(lambda (value)
|
||||
(define (ietf-token value)
|
||||
(let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)])
|
||||
(and ans (cdr ans)))))
|
||||
(and ans (cdr ans))))
|
||||
|
||||
;; Directly from RFC 1700:
|
||||
;; Type Subtype Description Reference
|
||||
|
|
@ -619,48 +592,43 @@
|
|||
|
||||
;; x-token := <The two characters "X-" or "x-" followed, with
|
||||
;; no intervening white space, by any token>
|
||||
(define x-token
|
||||
(lambda (value)
|
||||
(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))))
|
||||
h)))
|
||||
|
||||
;; subtype := extension-token / iana-token
|
||||
(define subtype
|
||||
(lambda (value)
|
||||
(define (subtype value)
|
||||
(if (not value)
|
||||
(raise (make-empty-subtype))
|
||||
(or (extension-token value)
|
||||
(iana-token value)))))
|
||||
(iana-token value))))
|
||||
|
||||
;; iana-token := <A publicly-defined extension token. Tokens
|
||||
;; of this form must be registered with IANA
|
||||
;; as specified in RFC 2048.>
|
||||
(define iana-token
|
||||
(lambda (value)
|
||||
(define (iana-token value)
|
||||
(let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)])
|
||||
(and ans (cdr ans)))))
|
||||
(and ans (cdr ans))))
|
||||
|
||||
;; parameter := attribute "=" value
|
||||
(define re:parameter (regexp "([^=]+)=(.+)"))
|
||||
(define parameter
|
||||
(lambda (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)))))
|
||||
(cons "???" par))))
|
||||
|
||||
;; value := token / quoted-string
|
||||
(define value
|
||||
(lambda (val)
|
||||
(define (value val)
|
||||
(or (token val)
|
||||
(quoted-string val)
|
||||
val)))
|
||||
val))
|
||||
|
||||
;; token := 1*<any (US-ASCII) CHAR except SPACE, CTLs,
|
||||
;; or tspecials>
|
||||
|
|
@ -669,13 +637,12 @@
|
|||
;; "/" / "[" / "]" / "?" / "="
|
||||
;; ; Must be in quoted-string,
|
||||
;; ; to use within parameter values
|
||||
(define token
|
||||
(lambda (value)
|
||||
(define (token value)
|
||||
(let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")]
|
||||
[ans (regexp-match tspecials value)])
|
||||
(and ans
|
||||
(string=? value (car ans))
|
||||
(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)
|
||||
(define (quoted-string str)
|
||||
(let* ([quotes re:quotes]
|
||||
[ans (regexp-match quotes str)])
|
||||
(and ans (regexp-replace quotes str "\\1")))))
|
||||
(and ans (regexp-replace quotes str "\\1"))))
|
||||
|
||||
;; disposition-parm := filename-parm
|
||||
;; / creation-date-parm
|
||||
|
|
@ -705,8 +671,7 @@
|
|||
;; read-date-parm := "read-date" "=" quoted-date-time
|
||||
;;
|
||||
;; size-parm := "size" "=" 1*DIGIT
|
||||
(define disp-params
|
||||
(lambda (lst disp)
|
||||
(define (disp-params lst disp)
|
||||
(let loop ([lst lst])
|
||||
(unless (null? lst)
|
||||
(let* ([p (parameter (trim-all-spaces (car lst)))]
|
||||
|
|
@ -734,7 +699,7 @@
|
|||
(set-disposition-params!
|
||||
disp
|
||||
(append (disposition-params disp) (list p)))])
|
||||
(loop (cdr lst)))))))
|
||||
(loop (cdr lst))))))
|
||||
|
||||
;; date-time = [ day "," ] date time ; dd mm yy
|
||||
;; ; hh:mm:ss zzz
|
||||
|
|
|
|||
|
|
@ -38,30 +38,27 @@
|
|||
|
||||
;; string-index returns the leftmost index in string s
|
||||
;; that has character c
|
||||
(define string-index
|
||||
(lambda (s c)
|
||||
(define (string-index s c)
|
||||
(let ([n (string-length s)])
|
||||
(let loop ([i 0])
|
||||
(cond [(>= i n) #f]
|
||||
[(char=? (string-ref s i) c) i]
|
||||
[else (loop (+ i 1))])))))
|
||||
[else (loop (+ i 1))]))))
|
||||
|
||||
;; string-tokenizer breaks string s into substrings separated by character c
|
||||
(define string-tokenizer
|
||||
(lambda (c 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)))))))
|
||||
(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)
|
||||
(define (trim-all-spaces str)
|
||||
;; Break out alternate quoted and unquoted parts.
|
||||
;; Initial and final string are unquoted.
|
||||
(let-values ([(unquoted quoted)
|
||||
|
|
@ -88,34 +85,29 @@
|
|||
(list clean)
|
||||
(list* clean
|
||||
(car quoted)
|
||||
(loop (cdr unquoted) (cdr 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)
|
||||
(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))))
|
||||
str)))
|
||||
|
||||
(define lowercase
|
||||
(lambda (str)
|
||||
(define (lowercase str)
|
||||
(let loop ([out ""] [rest str] [size (string-length str)])
|
||||
(cond [(zero? size) out]
|
||||
[else
|
||||
|
|
@ -123,7 +115,7 @@
|
|||
(char-downcase
|
||||
(string-ref rest 0))))
|
||||
(substring rest 1 size)
|
||||
(sub1 size))]))))
|
||||
(sub1 size))])))
|
||||
|
||||
(define warning
|
||||
void
|
||||
|
|
|
|||
|
|
@ -35,13 +35,12 @@
|
|||
|
||||
;; - throws an exception
|
||||
|
||||
(define signal-error
|
||||
(lambda (constructor format-string . 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)))))
|
||||
exn-args))))
|
||||
|
||||
;; default-nntpd-port-number :
|
||||
;; number
|
||||
|
|
@ -80,16 +79,14 @@
|
|||
;; close-communicator :
|
||||
;; communicator -> ()
|
||||
|
||||
(define close-communicator
|
||||
(lambda (communicator)
|
||||
(define (close-communicator communicator)
|
||||
(close-input-port (communicator-receiver communicator))
|
||||
(close-output-port (communicator-sender communicator))))
|
||||
(close-output-port (communicator-sender communicator)))
|
||||
|
||||
;; disconnect-from-server :
|
||||
;; communicator -> ()
|
||||
|
||||
(define disconnect-from-server
|
||||
(lambda (communicator)
|
||||
(define (disconnect-from-server communicator)
|
||||
(send-to-server communicator "QUIT")
|
||||
(let-values ([(code response)
|
||||
(get-single-line-response communicator)])
|
||||
|
|
@ -100,14 +97,13 @@
|
|||
((signal-error make-unexpected-response
|
||||
"unexpected dis-connect response: ~s ~s"
|
||||
code response)
|
||||
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 (authenticate-user communicator user password)
|
||||
(define (reject code response)
|
||||
((signal-error make-authentication-rejected
|
||||
"authentication rejected (~s ~s)"
|
||||
|
|
@ -131,24 +127,22 @@
|
|||
[else (unexpected code response)]))]
|
||||
[(502) (reject code response)]
|
||||
[else (reject code response)
|
||||
(unexpected code response)]))))
|
||||
(unexpected code response)])))
|
||||
|
||||
;; send-to-server :
|
||||
;; communicator x format-string x list (values) -> ()
|
||||
|
||||
(define send-to-server
|
||||
(lambda (communicator message-template . rest)
|
||||
(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))))
|
||||
(flush-output sender)))
|
||||
|
||||
;; parse-status-line :
|
||||
;; string -> number x string
|
||||
|
||||
(define parse-status-line
|
||||
(lambda (line)
|
||||
(define (parse-status-line line)
|
||||
(if (eof-object? line)
|
||||
((signal-error make-bad-status-line "eof instead of a status line")
|
||||
line)
|
||||
|
|
@ -157,29 +151,26 @@
|
|||
"malformed status line: ~s" line)
|
||||
line)))])
|
||||
(values (string->number (car match))
|
||||
(cadr 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)
|
||||
(define (get-rest-of-multi-line-response communicator)
|
||||
(let ([receiver (communicator-receiver communicator)])
|
||||
(let loop ()
|
||||
(let ([l (get-one-line-from-server receiver)])
|
||||
|
|
@ -193,7 +184,7 @@
|
|||
[(string=? l "..")
|
||||
(cons "." (loop))]
|
||||
[else
|
||||
(cons l (loop))]))))))
|
||||
(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)
|
||||
(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))))))
|
||||
(values code rest-of-line (get-rest-of-multi-line-response)))))
|
||||
|
||||
;; open-news-group :
|
||||
;; communicator x string -> number x number x number
|
||||
|
|
@ -215,8 +205,7 @@
|
|||
;; -- 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)
|
||||
(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)])
|
||||
|
|
@ -243,13 +232,12 @@
|
|||
[else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected group opening response: ~s" code)
|
||||
code rest-of-line)]))))
|
||||
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)
|
||||
(define (generic-message-command command ok-code)
|
||||
(lambda (communicator message-index)
|
||||
(send-to-server communicator (string-append command " ~a")
|
||||
(if (number? message-index)
|
||||
|
|
@ -274,7 +262,7 @@
|
|||
[else
|
||||
((signal-error make-unexpected-response
|
||||
"unexpected message access response: ~s" code)
|
||||
code response)]))))))
|
||||
code response)])))))
|
||||
|
||||
;; head-of-message :
|
||||
;; communicator x (number U string) -> list (string)
|
||||
|
|
@ -297,8 +285,7 @@
|
|||
;; make-desired-header :
|
||||
;; string -> desired
|
||||
|
||||
(define make-desired-header
|
||||
(lambda (raw-header)
|
||||
(define (make-desired-header raw-header)
|
||||
(regexp
|
||||
(string-append
|
||||
"^"
|
||||
|
|
@ -313,13 +300,12 @@
|
|||
[else
|
||||
(list c)]))
|
||||
(string->list raw-header))))
|
||||
":"))))
|
||||
":")))
|
||||
|
||||
;; extract-desired-headers :
|
||||
;; list (string) x list (desired) -> list (string)
|
||||
|
||||
(define extract-desired-headers
|
||||
(lambda (headers desireds)
|
||||
(define (extract-desired-headers headers desireds)
|
||||
(let loop ([headers headers])
|
||||
(if (null? headers) null
|
||||
(let ([first (car headers)]
|
||||
|
|
@ -328,4 +314,4 @@
|
|||
(regexp-match matcher first))
|
||||
desireds)
|
||||
(cons first (loop rest))
|
||||
(loop rest))))))))
|
||||
(loop rest)))))))
|
||||
|
|
|
|||
|
|
@ -29,14 +29,13 @@
|
|||
;; (exn-args ... -> exn) x format-string x values ... ->
|
||||
;; exn-args -> ()
|
||||
|
||||
(define signal-error
|
||||
(lambda (constructor format-string . 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)))))
|
||||
exn-args))))
|
||||
|
||||
;; signal-malformed-response-error :
|
||||
;; exn-args -> ()
|
||||
|
|
@ -52,11 +51,10 @@
|
|||
|
||||
;; -- signals an error otherwise.
|
||||
|
||||
(define confirm-transaction-mode
|
||||
(lambda (communicator error-message)
|
||||
(define (confirm-transaction-mode communicator error-message)
|
||||
(unless (eq? (communicator-state communicator) 'transaction)
|
||||
((signal-error make-not-ready-for-transaction error-message)
|
||||
communicator))))
|
||||
communicator)))
|
||||
|
||||
;; default-pop-port-number :
|
||||
;; number
|
||||
|
|
@ -98,8 +96,7 @@
|
|||
;; -- if authentication succeeds, sets the communicator's state to
|
||||
;; transaction.
|
||||
|
||||
(define authenticate/plain-text
|
||||
(lambda (username password communicator)
|
||||
(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)])
|
||||
|
|
@ -115,15 +112,14 @@
|
|||
"password was rejected"))]))]
|
||||
[(-err? status)
|
||||
((signal-error make-username-rejected
|
||||
"username was 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)
|
||||
(define (get-mailbox-status communicator)
|
||||
(confirm-transaction-mode
|
||||
communicator
|
||||
"cannot get mailbox status unless in transaction mode")
|
||||
|
|
@ -135,14 +131,14 @@
|
|||
communicator
|
||||
#rx"([0-9]+) ([0-9]+)"
|
||||
#f)])
|
||||
result)))))
|
||||
result))))
|
||||
|
||||
;; get-message/complete :
|
||||
;; communicator x number -> list (string) x list (string)
|
||||
|
||||
(define get-message/complete
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
(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)])
|
||||
|
|
@ -152,14 +148,14 @@
|
|||
[(-err? status)
|
||||
((signal-error make-illegal-message-number
|
||||
"not given message ~a" message)
|
||||
communicator message)]))))
|
||||
communicator message)])))
|
||||
|
||||
;; get-message/headers :
|
||||
;; communicator x number -> list (string)
|
||||
|
||||
(define get-message/headers
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
(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)])
|
||||
|
|
@ -172,23 +168,21 @@
|
|||
[(-err? status)
|
||||
((signal-error make-not-given-headers
|
||||
"not given headers to message ~a" message)
|
||||
communicator message)]))))
|
||||
communicator message)])))
|
||||
|
||||
;; get-message/body :
|
||||
;; communicator x number -> list (string)
|
||||
|
||||
(define get-message/body
|
||||
(lambda (communicator message)
|
||||
(define (get-message/body communicator message)
|
||||
(let-values ([(headers body) (get-message/complete communicator message)])
|
||||
body)))
|
||||
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)
|
||||
(define (split-header/body lines)
|
||||
(let loop ([lines lines] [header null])
|
||||
(if (null? lines)
|
||||
(values (reverse header) null)
|
||||
|
|
@ -196,14 +190,14 @@
|
|||
[rest (cdr lines)])
|
||||
(if (string=? first "")
|
||||
(values (reverse header) rest)
|
||||
(loop rest (cons first header))))))))
|
||||
(loop rest (cons first header)))))))
|
||||
|
||||
;; delete-message :
|
||||
;; communicator x number -> ()
|
||||
|
||||
(define delete-message
|
||||
(lambda (communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
(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)])
|
||||
|
|
@ -213,7 +207,7 @@
|
|||
"no message numbered ~a available to be deleted" message)
|
||||
communicator message)]
|
||||
[(+ok? status)
|
||||
'deleted]))))
|
||||
'deleted])))
|
||||
|
||||
;; regexp for UIDL responses
|
||||
|
||||
|
|
@ -223,7 +217,8 @@
|
|||
;; communicator x number -> string
|
||||
|
||||
(define (get-unique-id/single communicator message)
|
||||
(confirm-transaction-mode communicator
|
||||
(confirm-transaction-mode
|
||||
communicator
|
||||
"cannot get unique message id unless in transaction state")
|
||||
(send-to-server communicator "UIDL ~a" message)
|
||||
(let-values ([(status result)
|
||||
|
|
@ -259,16 +254,14 @@
|
|||
;; close-communicator :
|
||||
;; communicator -> ()
|
||||
|
||||
(define close-communicator
|
||||
(lambda (communicator)
|
||||
(define (close-communicator communicator)
|
||||
(close-input-port (communicator-receiver communicator))
|
||||
(close-output-port (communicator-sender communicator))))
|
||||
(close-output-port (communicator-sender communicator)))
|
||||
|
||||
;; disconnect-from-server :
|
||||
;; communicator -> ()
|
||||
|
||||
(define disconnect-from-server
|
||||
(lambda (communicator)
|
||||
(define (disconnect-from-server communicator)
|
||||
(send-to-server communicator "QUIT")
|
||||
(set-communicator-state! communicator 'disconnected)
|
||||
(let ([response (get-status-response/basic communicator)])
|
||||
|
|
@ -278,24 +271,22 @@
|
|||
[(-err? response)
|
||||
((signal-error make-disconnect-not-quiet
|
||||
"got error status upon disconnect")
|
||||
communicator)]))))
|
||||
communicator)])))
|
||||
|
||||
;; send-to-server :
|
||||
;; communicator x format-string x list (values) -> ()
|
||||
|
||||
(define send-to-server
|
||||
(lambda (communicator message-template . rest)
|
||||
(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))))
|
||||
(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,8 +296,7 @@
|
|||
;; rest of the status response as a string to be used for further
|
||||
;; parsing, if necessary.
|
||||
|
||||
(define get-server-status-response
|
||||
(lambda (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)])
|
||||
|
|
@ -315,7 +305,7 @@
|
|||
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
|
||||
(if r
|
||||
(values (make--err) (cadr r))
|
||||
(signal-malformed-response-error communicator)))))))
|
||||
(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)
|
||||
(define (get-status-response/basic communicator)
|
||||
(let-values ([(response rest)
|
||||
(get-server-status-response communicator)])
|
||||
response)))
|
||||
response))
|
||||
|
||||
;; get-status-response/match :
|
||||
;; communicator x regexp x regexp -> (status x list (string))
|
||||
|
|
@ -335,8 +324,7 @@
|
|||
;; -- 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)
|
||||
(define (get-status-response/match communicator +regexp -regexp)
|
||||
(let-values ([(response rest)
|
||||
(get-server-status-response communicator)])
|
||||
(if (and +regexp (+ok? response))
|
||||
|
|
@ -347,13 +335,12 @@
|
|||
(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)
|
||||
(define (get-multi-line-response communicator)
|
||||
(let ([receiver (communicator-receiver communicator)])
|
||||
(let loop ()
|
||||
(let ([l (get-one-line-from-server receiver)])
|
||||
|
|
@ -366,13 +353,12 @@
|
|||
(char=? (string-ref l 0) #\.))
|
||||
(cons (substring l 1 (string-length l)) (loop))]
|
||||
[else
|
||||
(cons l (loop))]))))))
|
||||
(cons l (loop))])))))
|
||||
|
||||
;; make-desired-header :
|
||||
;; string -> desired
|
||||
|
||||
(define make-desired-header
|
||||
(lambda (raw-header)
|
||||
(define (make-desired-header raw-header)
|
||||
(regexp
|
||||
(string-append
|
||||
"^"
|
||||
|
|
@ -387,13 +373,12 @@
|
|||
[else
|
||||
(list c)]))
|
||||
(string->list raw-header))))
|
||||
":"))))
|
||||
":")))
|
||||
|
||||
;; extract-desired-headers :
|
||||
;; list (string) x list (desired) -> list (string)
|
||||
|
||||
(define extract-desired-headers
|
||||
(lambda (headers desireds)
|
||||
(define (extract-desired-headers headers desireds)
|
||||
(let loop ([headers headers])
|
||||
(if (null? headers) null
|
||||
(let ([first (car headers)]
|
||||
|
|
@ -402,4 +387,4 @@
|
|||
(regexp-match matcher first))
|
||||
desireds)
|
||||
(cons first (loop rest))
|
||||
(loop rest))))))))
|
||||
(loop rest)))))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user