244 lines
7.0 KiB
Scheme
244 lines
7.0 KiB
Scheme
|
|
(unit/sig mzlib:head^
|
|
(import)
|
|
|
|
(define empty-header (string #\return #\newline))
|
|
|
|
(define (string->ci-regexp s)
|
|
(list->string
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (c)
|
|
(cond
|
|
[(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
|
|
(list #\\ c)]
|
|
[(char-alphabetic? c)
|
|
(list #\[ (char-upcase c) (char-downcase c) #\])]
|
|
[else (list c)]))
|
|
(string->list s)))))
|
|
|
|
(define re:field-start (regexp
|
|
(format "^[^~a~a~a~a~a:~a-~a]*:"
|
|
#\space #\tab #\linefeed #\return #\vtab
|
|
(integer->char 1)
|
|
(integer->char 26))))
|
|
(define re:continue (regexp (format "^[~a~a~a]" #\space #\tab #\vtab)))
|
|
|
|
(define (validate-header s)
|
|
(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 (string #\return #\linefeed) 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 "(^|[~a][~a])(~a: *)"
|
|
#\return #\linefeed
|
|
(string->ci-regexp field)))
|
|
|
|
(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
|
|
(format "[~a][~a][^: ~a~a]*:"
|
|
#\return #\linefeed
|
|
#\return #\linefeed)
|
|
s)])
|
|
(if m
|
|
(substring s 0 (caar m))
|
|
; Rest of header is this field, but strip trailing CRLFCRLF:
|
|
(regexp-replace (format "~a~a~a~a$" #\return #\linefeed #\return #\linefeed)
|
|
s
|
|
"")))))))
|
|
|
|
(define (remove-field field 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
|
|
(format "[~a][~a][^: ~a~a]*:"
|
|
#\return #\linefeed
|
|
#\return #\linefeed)
|
|
s)])
|
|
(if m
|
|
(string-append pre (substring s (+ 2 (caar m))
|
|
(string-length s)))
|
|
pre)))
|
|
header)))
|
|
|
|
(define (insert-field field data header)
|
|
(let ([field (format "~a: ~a~a~a"
|
|
field
|
|
data
|
|
#\return #\linefeed)])
|
|
(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 (standard-message-header from tos ccs bccs subject)
|
|
(let ([h (insert-field
|
|
"Subject" subject
|
|
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 (format "~a~a~a" #\return #\linefeed #\tab)))
|
|
|
|
;;; Extracting Addresses ;;;
|
|
|
|
(define blank (format "[~a~a~a~a~a]" #\space #\tab #\newline #\return #\vtab))
|
|
(define re:all-blank (regexp (format "^~a*$" blank)))
|
|
|
|
(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 "\"[^\"]*\"" s)]
|
|
[mc (regexp-match-positions "," 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 "([^,]*),(.*)" 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 (extract-one-name s form)
|
|
(cond
|
|
[(regexp-match (format "^~a*(\"[^\"]*\")(.*)" blank) s)
|
|
=> (lambda (m)
|
|
(let ([name (cadr m)]
|
|
[addr (extract-angle-addr (caddr m))])
|
|
(select-result form name addr
|
|
(format "~a <~a>" name addr))))]
|
|
; ?!?!? Where does the "addr (name)" standard come from ?!?!?
|
|
[(regexp-match (format "(.*)[(]([^)]*)[)]~a*$" blank) s)
|
|
=> (lambda (m)
|
|
(let ([name (caddr m)]
|
|
[addr (extract-simple-addr (cadr m))])
|
|
(select-result form name addr
|
|
(format "~a (~a)" addr name))))]
|
|
[(regexp-match (format "^~a*(.*)(<.*>)~a*$" blank blank) s)
|
|
=> (lambda (m)
|
|
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
|
|
[addr (extract-angle-addr (caddr m))])
|
|
(select-result form name addr
|
|
(format "~a <~a>" name addr))))]
|
|
[(or (regexp-match "<" s) (regexp-match ">" s))
|
|
(one-result form (extract-angle-addr s))]
|
|
[else
|
|
(one-result form (extract-simple-addr s))]))
|
|
|
|
(define (extract-angle-addr s)
|
|
(if (or (regexp-match "<.*<" s) (regexp-match ">.*>" s))
|
|
(error 'extract-address "too many angle brackets: ~a" s)
|
|
(let ([m (regexp-match (format "~a*<([^>]*)>~a*" blank blank) s)])
|
|
(if m
|
|
(extract-simple-addr (cadr m))
|
|
(error 'extract-address "cannot parse address: ~a" s)))))
|
|
|
|
(define (extract-simple-addr s)
|
|
(cond
|
|
[(regexp-match "[,\"()<>]" s)
|
|
(error 'extract-address "cannot parse address: ~a" s)]
|
|
[else
|
|
; final whitespace strip
|
|
(regexp-replace
|
|
(format "~a*$" blank)
|
|
(regexp-replace (format "~a*" blank) 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)))))))))
|