286 lines
8.7 KiB
Scheme
286 lines
8.7 KiB
Scheme
|
|
(module head-unit mzscheme
|
|
(require (lib "unitsig.ss")
|
|
(lib "date.ss")
|
|
(lib "string.ss"))
|
|
|
|
(require "head-sig.ss")
|
|
|
|
(provide net:head@)
|
|
(define net:head@
|
|
(unit/sig net:head^
|
|
(import)
|
|
|
|
(define empty-header (string #\return #\newline))
|
|
|
|
(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:"))
|
|
(define re:continue (regexp "^[ \t\v]"))
|
|
|
|
(define (validate-header s)
|
|
(let ([m (regexp-match #rx"[^\000-\377]" s)])
|
|
(when m
|
|
(error 'validate-header "non-Latin-1 character in string: ~a" (car m))))
|
|
(let ([len (string-length s)])
|
|
(let loop ([offset 0])
|
|
(cond
|
|
[(and (= (+ offset 2) len)
|
|
(string=? empty-header (substring s offset len)))
|
|
(void)] ; validated
|
|
[(= offset len) (error 'validate-header "missing ending CRLF")]
|
|
[(or (regexp-match re:field-start s offset)
|
|
(regexp-match re:continue s offset))
|
|
(let ([m (regexp-match-positions #rx"\r\n" s offset)])
|
|
(if m
|
|
(loop (cdar m))
|
|
(error 'validate-header "missing ending CRLF")))]
|
|
[else (error 'validate-header "ill-formed header at ~s"
|
|
(substring s offset (string-length s)))]))))
|
|
|
|
(define (make-field-start-regexp field)
|
|
(format "(^|[\r][\n])(~a: *)" (regexp-quote field #f)))
|
|
|
|
(define (extract-field field header)
|
|
(let ([m (regexp-match-positions
|
|
(make-field-start-regexp field)
|
|
header)])
|
|
(and m
|
|
(let ([s (substring header
|
|
(cdaddr m)
|
|
(string-length header))])
|
|
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
|
|
(if m
|
|
(substring s 0 (caar m))
|
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
|
(regexp-replace #rx"\r\n\r\n$"
|
|
s
|
|
"")))))))
|
|
|
|
(define (replace-field field data header)
|
|
(let ([m (regexp-match-positions
|
|
(make-field-start-regexp field)
|
|
header)])
|
|
(if m
|
|
(let ([pre (substring header
|
|
0
|
|
(caaddr m))]
|
|
[s (substring header
|
|
(cdaddr m)
|
|
(string-length header))])
|
|
(let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)])
|
|
(if m
|
|
(string-append pre
|
|
(let ([rest
|
|
(substring s (+ 2 (caar m))
|
|
(string-length s))])
|
|
(if data
|
|
(insert-field field data rest)
|
|
rest)))
|
|
(if data
|
|
(insert-field field data pre)
|
|
pre))))
|
|
(if data
|
|
(insert-field field data header)
|
|
header))))
|
|
|
|
(define (remove-field field header)
|
|
(replace-field field #f header))
|
|
|
|
|
|
(define (insert-field field data header)
|
|
(let ([field (format "~a: ~a\r\n"
|
|
field
|
|
data)])
|
|
(string-append field header)))
|
|
|
|
(define (append-headers a b)
|
|
(let ([alen (string-length a)])
|
|
(if (> alen 1)
|
|
(string-append (substring a 0 (- alen 2)) b)
|
|
(error 'append-headers "first argument is not a header: ~a" a))))
|
|
|
|
(define (extract-all-fields header)
|
|
(let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"])
|
|
(let loop ([start 0])
|
|
(let ([m (regexp-match-positions re header start)])
|
|
(if m
|
|
(let ([start (cdaddr m)]
|
|
[field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))])
|
|
(let ([m2 (regexp-match-positions
|
|
#rx"\r\n[^: \r\n\"]*:"
|
|
header
|
|
start)])
|
|
(if m2
|
|
(cons (cons field-name
|
|
(substring header start (caar m2)))
|
|
(loop (caar m2)))
|
|
;; Rest of header is this field, but strip trailing CRLFCRLF:
|
|
(list
|
|
(cons field-name
|
|
(regexp-replace (format "~a~a~a~a$" #\return #\linefeed #\return #\linefeed)
|
|
(substring header start (string-length header))
|
|
""))))))
|
|
;; malformed header:
|
|
null)))))
|
|
|
|
(define (standard-message-header from tos ccs bccs subject)
|
|
(let ([h (insert-field
|
|
"Subject" subject
|
|
(insert-field
|
|
"Date" (parameterize ([date-display-format 'rfc2822])
|
|
(date->string (seconds->date (current-seconds)) #t))
|
|
empty-header))])
|
|
;; NOTE: bccs don't go into the header; that's why
|
|
;; they're "blind"
|
|
(let ([h (if (null? ccs)
|
|
h
|
|
(insert-field
|
|
"CC" (assemble-address-field ccs)
|
|
h))])
|
|
(let ([h (if (null? tos)
|
|
h
|
|
(insert-field
|
|
"To" (assemble-address-field tos)
|
|
h))])
|
|
(insert-field
|
|
"From" from
|
|
h)))))
|
|
|
|
(define (splice l sep)
|
|
(if (null? l)
|
|
""
|
|
(format "~a~a"
|
|
(car l)
|
|
(apply
|
|
string-append
|
|
(map
|
|
(lambda (n) (format "~a~a" sep n))
|
|
(cdr l))))))
|
|
|
|
(define (data-lines->data datas)
|
|
(splice datas "\r\n\t"))
|
|
|
|
;; Extracting Addresses ;;
|
|
|
|
(define blank "[ \t\n\r\v]")
|
|
(define nonblank "[^ \t\n\r\v]")
|
|
(define re:all-blank (regexp (format "^~a*$" blank)))
|
|
(define re:quoted (regexp "\"[^\"]*\""))
|
|
(define re:comma (regexp ","))
|
|
(define re:comma-separated (regexp "([^,]*),(.*)"))
|
|
|
|
(define (extract-addresses s form)
|
|
(unless (memq form '(name address full all))
|
|
(raise-type-error 'extract-addresses
|
|
"form: 'name, 'address, 'full, or 'all"
|
|
form))
|
|
(if (or (not s) (regexp-match re:all-blank s))
|
|
null
|
|
(let loop ([prefix ""][s s])
|
|
;; Which comes first - a quote or a comma?
|
|
(let ([mq (regexp-match-positions re:quoted s)]
|
|
[mc (regexp-match-positions re:comma s)])
|
|
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
|
|
;; Quote contains a comma
|
|
(loop (string-append
|
|
prefix
|
|
(substring s 0 (cdar mq)))
|
|
(substring s (cdar mq) (string-length s)))
|
|
;; Normal comma parsing:
|
|
(let ([m (regexp-match re:comma-separated s)])
|
|
(if m
|
|
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
|
|
[rest (extract-addresses (caddr m) form)])
|
|
(cons n rest))
|
|
(let ([n (extract-one-name (string-append prefix s) form)])
|
|
(list n)))))))))
|
|
|
|
(define (select-result form name addr full)
|
|
(case form
|
|
[(name) name]
|
|
[(address) addr]
|
|
[(full) full]
|
|
[(all) (list name addr full)]))
|
|
|
|
(define (one-result form s)
|
|
(select-result form s s s))
|
|
|
|
(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank)))
|
|
(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank)))
|
|
(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank)))
|
|
(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank)))
|
|
(define re:double-less (regexp "<.*<"))
|
|
(define re:double-greater (regexp ">.*>"))
|
|
(define re:bad-chars (regexp "[,\"()<>]"))
|
|
(define re:tail-blanks (regexp (format "~a+$" blank)))
|
|
(define re:head-blanks (regexp (format "^~a+" blank)))
|
|
|
|
(define (extract-one-name orig form)
|
|
(let loop ([s orig][form form])
|
|
(cond
|
|
;; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
|
[(regexp-match re:parened-name s)
|
|
=> (lambda (m)
|
|
(let ([name (caddr m)]
|
|
[all (loop (cadr m) 'all)])
|
|
(select-result form
|
|
(if (string=? (car all) (cadr all))
|
|
name
|
|
(car all))
|
|
(cadr all)
|
|
(format "~a (~a)" (caddr all) name))))]
|
|
[(regexp-match re:quoted-name s)
|
|
=> (lambda (m)
|
|
(let ([name (cadr m)]
|
|
[addr (extract-angle-addr (caddr m) s)])
|
|
(select-result form name addr
|
|
(format "~a <~a>" name addr))))]
|
|
[(regexp-match re:simple-name s)
|
|
=> (lambda (m)
|
|
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
|
[addr (extract-angle-addr (caddr m) s)])
|
|
(select-result form name addr
|
|
(format "~a <~a>" name addr))))]
|
|
[(or (regexp-match "<" s) (regexp-match ">" s))
|
|
(one-result form (extract-angle-addr s orig))]
|
|
[else
|
|
(one-result form (extract-simple-addr s orig))])))
|
|
|
|
(define (extract-angle-addr s orig)
|
|
(if (or (regexp-match re:double-less s) (regexp-match re:double-greater s))
|
|
(error 'extract-address "too many angle brackets: ~a" s)
|
|
(let ([m (regexp-match re:normal-name s)])
|
|
(if m
|
|
(extract-simple-addr (cadr m) orig)
|
|
(error 'extract-address "cannot parse address: ~a" orig)))))
|
|
|
|
(define (extract-simple-addr s orig)
|
|
(cond
|
|
[(regexp-match re:bad-chars s)
|
|
(error 'extract-address "cannot parse address: ~a" orig)]
|
|
[else
|
|
;; final whitespace strip
|
|
(regexp-replace
|
|
re:tail-blanks
|
|
(regexp-replace re:head-blanks s "")
|
|
"")]))
|
|
|
|
(define (assemble-address-field addresses)
|
|
(if (null? addresses)
|
|
""
|
|
(let loop ([addresses (cdr addresses)]
|
|
[s (car addresses)]
|
|
[len (string-length (car addresses))])
|
|
(if (null? addresses)
|
|
s
|
|
(let* ([addr (car addresses)]
|
|
[alen (string-length addr)])
|
|
(if (<= 72 (+ len alen))
|
|
(loop (cdr addresses)
|
|
(format "~a,~a~a~a~a"
|
|
s #\return #\linefeed
|
|
#\tab addr)
|
|
alen)
|
|
(loop (cdr addresses)
|
|
(format "~a, ~a" s addr)
|
|
(+ len alen 2)))))))))))
|