136 lines
6.3 KiB
Racket
136 lines
6.3 KiB
Racket
#lang racket/base
|
|
(require net/base64 net/qp)
|
|
|
|
(provide encode-for-header decode-for-header generalize-encoding)
|
|
|
|
(define re:non-ascii #rx"[^\u0-\u7F]")
|
|
|
|
(define (encode-for-header s)
|
|
(cond [(not (regexp-match? re:non-ascii s)) s]
|
|
[(not (regexp-match? #rx"[\r\n]" s)) (encode-line-for-header s)] ; speed
|
|
[else (regexp-replace* #rx"[^\r\n]+" s encode-line-for-header)]))
|
|
|
|
;; Note: the following two encoder wrappers remove newlines from the
|
|
;; encoded strings. This avoids producing invalid strings, but it's not
|
|
;; complete: rfc2047 (section 2) specifies that encoded words should not
|
|
;; be longer than 75 characters, and longer words should be split for
|
|
;; encoding with a separator of CRLF SPACE between them. The problem is
|
|
;; that doing this properly requires changing the encoders to get a
|
|
;; length limit and have them return also the leftover unencoded string.
|
|
;; Instead of doing all of that, do something simpler: if the string to
|
|
;; be encoded is longer than 70 characters, then split it. (This is
|
|
;; done in `encode-line-for-header' below.) It's possible to get longer
|
|
;; encodings with this, but it seems that sendmail's limit on line
|
|
;; lengths is sufficiently larger that it works fine in practice. (BTW,
|
|
;; when sendmail gets lines that are too long it splits them with the
|
|
;; dreaded "!\n ", and it looks like there is no sane way to avoid that
|
|
;; behavior -- so splitting the input is needed.)
|
|
|
|
(define (base64-encode-header s)
|
|
(regexp-replace* #rx#"[\r\n]+" (base64-encode s) #""))
|
|
|
|
(define (qp-encode-header s)
|
|
;; rfc2047 (section 4.2) calls this "Q encoding", which is different
|
|
;; from the usual QP encoding: encode underlines and question marks,
|
|
;; and replace spaces by underlines; also remove soft-newlines.
|
|
(regexp-replace* #rx#"[ ?_]"
|
|
(regexp-replace* #rx#"=\r?\n" (qp-encode s) #"")
|
|
(λ (b)
|
|
(case (bytes-ref b 0)
|
|
[(32) #"_"] ; " "
|
|
[(63) #"=3F"] ; "?"
|
|
[(95) #"=5F"] ; "_"
|
|
[else (error 'qp-encode-header "internal error")]))))
|
|
|
|
(define (encode-line-for-header s)
|
|
(define (do-encode s string->bytes charset encode encoding)
|
|
(let loop ([s s])
|
|
(cond
|
|
;; Find ASCII (and no "=") prefix before a space
|
|
[(regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)
|
|
=> (λ (m) (string-append (cadr m) (loop (caddr m))))]
|
|
;; Find ASCII (and no "=") suffix after a space
|
|
[(regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)
|
|
=> (λ (m) (string-append (loop (cadr m)) (caddr m)))]
|
|
[else
|
|
;; Split lines longer than 70 chars and re-assemble (see above
|
|
;; comment). Note that the proper separator should use CRLF,
|
|
;; but we're sending this to a sendmail process that will take
|
|
;; care of that level.
|
|
(let loop ([bytes (string->bytes s)])
|
|
(if ((bytes-length bytes) . > . 70)
|
|
(string-append (loop (subbytes bytes 0 70))
|
|
"\n "
|
|
(loop (subbytes bytes 70)))
|
|
(format "=?~a?~a?~a?=" charset encoding (encode bytes))))])))
|
|
(cond
|
|
;; ASCII - do nothing
|
|
[(not (regexp-match? re:non-ascii s)) s]
|
|
;; Not Latin-1, so use UTF-8
|
|
[(regexp-match? #rx"[^\u0-\uFF]" s)
|
|
(do-encode s string->bytes/utf-8 "UTF-8" base64-encode-header "B")]
|
|
;; use Latin-1
|
|
[else
|
|
(do-encode s string->bytes/latin-1 "ISO-8859-1" qp-encode-header "Q")]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$")
|
|
|
|
(define (generalize-encoding encoding)
|
|
;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312
|
|
;; as GBK, because some mailers are broken.
|
|
(cond [(or (regexp-match? #rx#"^(?i:iso-8859-1)$" encoding)
|
|
(regexp-match? #rx#"^(?i:us-ascii)$" encoding))
|
|
(if (bytes? encoding) #"WINDOWS-1252" "WINDOWS-1252")]
|
|
[(regexp-match? #rx#"^(?i:gb(?:2312)?)$" encoding)
|
|
(if (bytes? encoding) #"GBK" "GBK")]
|
|
[(regexp-match? #rx#"^(?i:ks_c_5601-1987)$" encoding)
|
|
(if (bytes? encoding) #"CP949" "CP949")]
|
|
[else encoding]))
|
|
|
|
(define (decode-for-header s)
|
|
(and s
|
|
(let ([m (regexp-match re:encoded
|
|
(string->bytes/latin-1 s (char->integer #\?)))])
|
|
(if m
|
|
(let ([s ((if (member (cadddr m) '(#"q" #"Q"))
|
|
;; quoted-printable, with special _ handling
|
|
(λ (x) (qp-decode (regexp-replace* #rx#"_" x #" ")))
|
|
;; base64:
|
|
base64-decode)
|
|
(cadddr (cdr m)))]
|
|
[encoding (caddr m)])
|
|
(string-append
|
|
(decode-for-header (bytes->string/latin-1 (cadr m)))
|
|
(let ([encoding (generalize-encoding encoding)])
|
|
(cond
|
|
[(regexp-match? #rx#"^(?i:utf-8)$" encoding)
|
|
(bytes->string/utf-8 s #\?)]
|
|
[else (let ([c (bytes-open-converter
|
|
(bytes->string/latin-1 encoding)
|
|
"UTF-8")])
|
|
(if c
|
|
(let-values ([(r got status)
|
|
(bytes-convert c s)])
|
|
(bytes-close-converter c)
|
|
(if (eq? status 'complete)
|
|
(bytes->string/utf-8 r #\?)
|
|
(bytes->string/latin-1 s)))
|
|
(bytes->string/latin-1 s)))]))
|
|
(let ([rest (cadddr (cddr m))])
|
|
(let ([rest
|
|
;; A CR-LF-space-encoding sequence means that we
|
|
;; should drop the space.
|
|
(if (and (> (bytes-length rest) 4)
|
|
(= 13 (bytes-ref rest 0))
|
|
(= 10 (bytes-ref rest 1))
|
|
(= 32 (bytes-ref rest 2))
|
|
(let ([m (regexp-match-positions
|
|
re:encoded rest)])
|
|
(and m (= (caaddr m) 5))))
|
|
(subbytes rest 3)
|
|
rest)])
|
|
(decode-for-header (bytes->string/latin-1 rest))))))
|
|
s))))
|