source: project/mime/tags/1.2/mime.scm @ 5249

Last change on this file since 5249 was 5246, checked in by hans, 14 years ago

added branches, tags and trunk directory

File size: 21.0 KB
Line 
1;;;
2;;; mime.scm - parsing MIME (rfc2045) message
3;;; 
4;;;   Copyright (c) 2000-2004 Shiro Kawai, All rights reserved.
5;;;   
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;   
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;; 
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;; 
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;; 
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;; 
33;;;  $Id: mime.scm,v 1.11 2004/11/25 22:00:43 shirok Exp $
34;;;
35;;; Ported to Chicken by Hans Bulfone <jsb@nil.at>
36
37;; RFC2045 Multipurpose Internet Mail Extensions (MIME)
38;;  Part One: Format of Internet Message Bodies
39;; RFC2046 Multipurpose Internet Mail Extensions (MIME)
40;;  Part Two: Media Types
41;; RFC2047 Multipurpose Internet Mail Extensions (MIME)
42;;  Part Three: Message Header Extensions for Non-ASCII Text
43;; RFC2048
44;; RFC2049
45
46(define-extension mime)
47(declare
48 (usual-integrations)
49 (uses mime:quoted-printable)
50 (export mime-parse-version mime-parse-content-type
51         mime-decode-word
52         mime-parse-message mime-retrieve-body
53         mime-body->string mime-body->file
54         make-mime-part mime-part?
55         mime-part:type mime-part:subtype mime-part:parameters
56         mime-part:transfer-encoding mime-part:parent mime-part:index
57         mime-part:headers mime-part:content mime-part:attrs
58         mime-part:type-set! mime-part:subtype-set! mime-part:parameters-set!
59         mime-part:transfer-encoding-set! mime-part:parent-set! mime-part:index-set!
60         mime-part:headers-set! mime-part:content-set! mime-part:attrs-set!
61         mime-part-write mime-part->string))
62(require-extension lolevel regex
63                   srfi-1 srfi-13 srfi-14
64                   rfc822  base64 iconv)
65
66(define-macro (let1 name val . body)
67  `(let ((,name ,val))
68     ,@body))
69
70;;===============================================================
71;; Basic utility
72;;
73
74;; returns list of major and minor versions in integers
75(define mime-parse-version
76  (let ((re-version (regexp "^([0-9]+)\.([0-9]+)$")))
77    (lambda (field)
78      (and field
79           (let1 s
80               (string-concatenate (map ->string (rfc822-field->tokens field)))
81             (cond ((string-search re-version s) =>
82                    (lambda (m) (map (lambda (s) (string->number s)) (cdr m))))
83                   (else #f)))))))
84
85;; returns (<type> <subtype> (<attribute> . <value>) ...)
86(define (mime-parse-content-type field)
87  (define token-chars
88    (char-set-difference
89     (ucs-range->char-set #x21 #x7f)
90     (char-set #\( #\) #\< #\> #\@ #\, #\; #\: #\\ #\" #\/ #\[ #\] #\? #\=)))
91  (define cs-quote (char-set #\"))
92  (define (get-attributes input r)
93    (cond ((and-let* (((eqv? #\; (rfc822-next-token input '())))
94                      (attr (rfc822-next-token input `(,token-chars)))
95                      ((string? attr))
96                      ((eqv? #\= (rfc822-next-token input '())))
97                      (val  (rfc822-next-token
98                             input
99                             `(,token-chars
100                               (,cs-quote . ,rfc822-quoted-string))))
101                      ((string? val)))
102             (cons attr val))
103           => (lambda (p) (get-attributes input (cons p r))))
104          (else (reverse! r))))
105
106  (and field
107       (call-with-input-string field
108         (lambda (input)
109           (let* ((type    (rfc822-next-token input `(,token-chars)))
110                  (slash   (rfc822-next-token input '()))
111                  (subtype (rfc822-next-token input `(,token-chars))))
112             (and (string? type)
113                  (eqv? #\/ slash)
114                  (string? subtype)
115                  (cons* (string-downcase type)
116                         (string-downcase subtype)
117                         (get-attributes input '()))))
118           ))))
119
120;; decode rfc2047-encoded word, i.e. "=?...?="
121;; if word isn't legal encoded word, it is returned as is.
122(define mime-decode-word
123  (letrec
124      ((re-word
125        (regexp "^=\\?([-!#-'*+[:alnum:]^-~]+)\\?([-!#-'*+[:alnum:]^-~]+)\\?([!->@-~]+)\\?=$"))
126;       (regexp "^=\\?([^? ]+)\\?([^? ]+)\\?([^? ]+)\\?=$"))
127       ;; this is taken from alex shinn's charconv egg:
128       (aliases (make-hash-table string=?))
129       (ces-normalize-name
130        (lambda (str)
131          (let ((str2 (string-upcase str)))
132            (hash-table-ref/default aliases str2 str2))))
133       (%ces-upper-compatible?
134        (lambda (a b)
135          (cond
136           ((not b) #t)
137           ((string=? b "UTF8") (string=? a "UTF8"))
138           ((string=? b "ASCII") (not (member a '("UTF16" "UTF32"))))
139           (else #f))))
140       (ces-upper-compatible?
141        (lambda (a b)
142          (%ces-upper-compatible? (ces-normalize-name a) (ces-normalize-name b))))
143       (ces-convert
144        (lambda (str from . o)
145          (let ((to (or (and (pair? o) (car o)) "UTF8")))
146            (if (ces-upper-compatible? to from)
147                str
148                (let ((cd (iconv-open to from)))
149                  (iconv cd str)))))))
150
151    (for-each
152     (lambda (ls)
153       (for-each
154        (cute hash-table-set! aliases <> (car ls))
155        (cdr ls)))
156     '(("UTF8" "UTF-8")
157       ("ISO-8859-1" "LATIN-1")
158       ("SHIFT_JIS" "SJIS" "SHIFTJIS" "SHIFT-JIS")
159       ("EUC-JP" "EUCJP" "EUC_JP")))
160
161    (lambda (word)
162      (cond
163       ((string-search re-word word)
164        => (match-lambda
165            ((_ charset encoding body)
166             (handle-exceptions
167                 exn
168                 word                   ; capture illegal encoding
169               (cond
170                ((string-ci=? encoding "q")
171                 (ces-convert
172                  (quoted-printable-decode-string body)
173                  charset #f))
174                ((string-ci=? encoding "b")
175                 (ces-convert
176                  (base64-decode-string body)
177                  charset #f))
178                (else word))))))        ; unsupported encoding
179       (else word)))))
180
181
182;;===============================================================
183;; Virtual port to recognize mime boundary
184;;
185
186(define read-byte
187  (let ((read-char read-char)
188        (char->integer char->integer))
189    (lambda (port)
190      (let ((ch (read-char port)))
191        (if (eof-object? ch)
192            ch
193            (char->integer ch))))))
194
195(define peek-byte
196  (let ((peek-char peek-char)
197        (char->integer char->integer))
198    (lambda (port)
199      (let ((ch (peek-char port)))
200        (if (eof-object? ch)
201            ch
202            (char->integer ch))))))
203
204;; Creates a procedural port, which reads from SRCPORT until it reaches
205;; either EOF or MIME boundary.  Basically it runs a DFA.
206(define (make-mime-port boundary srcport)
207  (define q (make-queue))
208  (define (enqueue! queue . items)
209    (if (null? items)
210        (void)
211        (begin
212          (queue-add! queue (car items))
213          (apply enqueue! queue (cdr items)))))
214  (define dequeue! queue-remove!)
215  (define --boundary (string->byte-vector (string-append "--" boundary)))
216
217  (define state 'prologue)
218
219  (define eof #!eof)
220
221  (define (deq! q)
222    (if (queue-empty? q) eof (dequeue! q)))
223 
224  (define (fifo! q b)
225    (enqueue! q b) (dequeue! q))
226
227  (define (getb)
228    (if (queue-empty? q)
229      (case state
230        ((prologue) (skip-prologue))
231        ((boundary eof) eof)
232        (else (newb)))
233      (dequeue! q)))
234
235  (define (newb)
236    (let1 b (read-byte srcport)
237      (cond
238       ((eof-object? b)
239        (set! state 'eof)
240        eof)
241       (else
242        (case b
243          ((#x0d) ;; CR, check to see LF
244           (let1 b2 (peek-byte srcport)
245             (if (eqv? b2 #x0a)
246               (begin
247                 (read-byte srcport)
248                 (enqueue! q b #x0a)
249                 (check-boundary))
250               b)))
251          ((#x0a) ;; LF, check boundary
252           (enqueue! q b) (check-boundary))
253          (else b))))))
254
255  (define (check-boundary)
256    (let loop ((b   (peek-byte srcport))
257               (ind 0)
258               (max (byte-vector-length --boundary)))
259      (cond ((eof-object? b)
260             (deq! q))
261            ((= ind max)
262             (cond ((memv b '(#x0d #x0a)) ;;found boundary
263                    (read-byte srcport)   ;;consume LF or CRLF
264                    (when (and (eqv? #x0d b) 
265                               (eqv? #x0a (peek-byte srcport)))
266                      (read-byte srcport))
267                    (set! q (make-queue))
268                    (set! state 'boundary)
269                    eof)
270                   ((eqv? b #x2d) ;; maybe end boundary
271                    (enqueue! q (read-byte srcport))
272                    (cond ((eqv? (peek-byte srcport) #x2d);; yes, end boundary
273                           (read-byte srcport)
274                           (set! q (make-queue))
275                           (skip-epilogue))
276                          (else
277                           (deq! q))))
278                   (else
279                    (deq! q))))
280            ((= b (byte-vector-ref --boundary ind))
281             (enqueue! q (read-byte srcport))
282             (loop (peek-byte srcport) (+ ind 1) max))
283            ((queue-empty? q)
284             (newb))
285            (else
286             (dequeue! q)))))
287
288  ;; Reads past the first boundary.  The first boundary may appear
289  ;; at the beginning of the message (instead of after CRLF), so
290  ;; we need slightly different handling than the normal getb.
291  (define (skip-prologue)
292    (let loop ((b (check-boundary)))
293      (cond
294       ((eof-object? b)
295        (cond ((eq? state 'boundary) ; we've found the boundary
296               (set! state 'body)
297               (getb))
298              (else                              ; no boundary found
299               (set! state 'eof)
300               eof)))
301       ((queue-empty? q)
302        (loop (newb)))
303       (else
304        (set! q (make-queue))
305        (loop (newb))))))
306
307  (define (skip-epilogue)
308    (let loop ((b (read-byte srcport)))
309      (if (eof-object? b)
310        (begin (set! state 'eof)
311               b)
312        (loop (read-byte srcport)))))
313 
314  (values
315   (make-input-port
316    (lambda ()
317      (let ((ch (getb)))
318        (if (eof-object? ch)
319            ch
320            (integer->char ch))))
321    (lambda ()
322      (or (not (queue-empty? q))
323          (char-ready? srcport)))
324    void)
325   (lambda () state)
326   (lambda (s) (set! state s))))
327
328;;===============================================================
329;; Basic streaming parser
330;;
331
332(define-record-type :mime-part
333  (*make-mime-part type subtype parameters transfer-encoding
334                   parent index headers content attrs)
335  mime-part?
336  (type mime-part:type mime-part:type-set!)
337  (subtype mime-part:subtype mime-part:subtype-set!)
338  (parameters mime-part:parameters mime-part:parameters-set!)
339  (transfer-encoding mime-part:transfer-encoding mime-part:transfer-encoding-set!)
340  (parent mime-part:parent mime-part:parent-set!)
341  (index mime-part:index mime-part:index-set!)
342  (headers mime-part:headers mime-part:headers-set!)
343  (content mime-part:content mime-part:content-set!)
344  (attrs mime-part:attrs mime-part:attrs-set!))
345
346(define (make-mime-part #!key (type "text") (subtype "plain")
347                        (parameters '())
348                        (transfer-encoding "7bit")
349                        (parent #f) (index 0) (headers '())
350                        (content #f) (attrs '()))
351  (*make-mime-part type subtype parameters transfer-encoding
352                   parent index headers content attrs))
353
354(define (mime-parse-message port headers handler)
355  (internal-parse port headers handler #f 0
356                  '("text" "plain" ("charset" . "us-ascii"))))
357
358(define (internal-parse port headers handler parent index default-type)
359  (let* ((ctype (or (mime-parse-content-type
360                     (rfc822-header-ref headers "content-type"))
361                    default-type))
362         (enc   (rfc822-header-ref headers "content-transfer-encoding" "7bit"))
363         (packet (*make-mime-part
364                  (car ctype) (cadr ctype) (cddr ctype)
365                  enc parent index headers #f '()))
366         )
367    (cond
368     ((equal? (car ctype) "multipart")
369      (multipart-parse port packet handler))
370     ((equal? (car ctype) "message")
371      (message-parse port packet handler))
372     (else
373      ;; normal body
374      (mime-part:content-set! packet (handler packet port))
375      packet)
376     )))
377
378(define (multipart-parse port packet handler)
379  (let ((boundary (or (alist-ref "boundary" (mime-part:parameters packet) equal?)
380                      (error "No boundary given for multipart message")))
381        (default-type (if (equal? (mime-part:subtype packet) "digest")
382                          '("message" "rfc822")
383                          '("text" "plain" ("charset" . "us-ascii")))))
384    (receive (mime-port mime-port-state mime-port-state-set!)
385        (make-mime-port boundary port)
386      (let loop ((index 0)
387                 (contents '()))
388        (let* ((headers (rfc822-header->list mime-port))
389               (r (internal-parse mime-port headers handler
390                                  packet index
391                                  default-type)))
392          (case (mime-port-state)
393            ((boundary)
394             (mime-port-state-set! 'body)
395             (loop (+ index 1) (cons r contents)))
396            ((eof)
397             (mime-part:content-set! packet (reverse! (cons r contents)))
398             packet)
399            (else
400             ;; parser returned without readling entire part.
401             ;; discard the rest of the part.
402             (let loop ((b (read-char port)))
403               (unless (eof-object? b)
404                 (loop (read-char port))))
405             packet)))))))
406
407(define (message-parse port packet handler)
408  (let* ((headers (rfc822-header->list port))
409         (r (internal-parse port headers handler packet 0
410                            '("text" "plain" ("charset" . "us-ascii")))))
411    (mime-part:content-set! packet (list r)))
412  packet)
413
414;;===============================================================
415;; Body readers
416;;
417
418(define (mime-retrieve-body packet inp outp)
419
420  (define (read-line/nl)
421    (let loop ((c (read-char inp))
422               (chars '()))
423      (cond ((eof-object? c)
424             (if (null? chars)
425               c
426               (reverse-list->string chars)))
427            ((char=? c #\newline)
428             (reverse-list->string (cons c chars)))
429            ((char=? c #\return)
430             (let1 c (peek-char inp)
431               (if (char=? c #\newline)
432                   (reverse-list->string
433                    (cons* (read-char inp) #\return chars))
434                   (reverse-list->string (cons #\return chars)))))
435            (else (loop (read-char inp) (cons c chars))))))
436 
437  (define (read-text decoder)
438    (let loop ((line (read-line/nl)))
439      (unless (eof-object? line)
440        (display (decoder line) outp)
441        (loop (read-line/nl)))))
442
443  (define (read-base64)
444    (display
445     (base64:decode
446      (with-output-to-string
447        (lambda ()
448          (let loop ((line (read-line inp)))
449            (unless (eof-object? line)
450              (display line)
451              (loop (read-line inp)))))))
452     outp))
453
454  (let ((enc (mime-part:transfer-encoding packet)))
455    (cond
456     ((string-ci=? enc "base64") (read-base64))
457     ((string-ci=? enc "quoted-printable")
458      (read-text quoted-printable-decode-string))
459     ((member enc '("7bit" "8bit" "binary") string-ci=?)
460      (let loop ((b (read-char inp)))
461        (unless (eof-object? b)
462          (write-char b outp)
463          (loop (read-char inp)))))
464     ))
465  )
466
467(define (mime-body->string packet inp)
468  (let ((s (open-output-string)))
469    (mime-retrieve-body packet inp s)
470    (get-output-string s)))
471
472(define (mime-body->file packet inp filename)
473  (call-with-output-file filename
474    (lambda (outp)
475      (mime-retrieve-body packet inp outp)))
476  filename)
477
478
479;;===============================================================
480;; RFC2822/MIME message generator
481;;
482
483(define (rfc822-header-fold h #!optional (col 78))
484  (define ws (char-set #\space #\tab))
485  (define (fold-pos s)
486    (let loop ((i (string-index s ws)) (p #f))
487      (cond
488       ((not i) p)
489       ((= i 0)
490        (loop (string-index s ws 1 (string-length s)) p))
491       ((and (> i 0) (char=? (string-ref s (- i 1)) #\\))
492        (loop (string-index s ws (+ i 1) (string-length s)) p))
493;       ((> i 998) p)
494       ((and p (> i col)) p)
495       ((> i col) i)
496       (else
497        (loop (string-index s ws (+ i 1) (string-length s)) i)))))
498  (define (fold1 s)
499    (cond
500     ((<= (string-length s) col)
501      (display s) #f)
502     ((fold-pos s)
503      => (lambda (p)
504           (display (substring s 0 p))
505           (display "\r\n")
506           (substring s p (string-length s))))
507     (else
508      ;; line is too long but we can't fold it (no whitespace)
509      (display s) #f)))
510
511  (if (string-any #\newline h)
512      h
513      (with-output-to-string
514        (lambda ()
515          (let loop ((h (fold1 h)))
516            (if h (loop (fold1 h))))))))
517
518(define (rfc822-header-upcase h)
519  (with-output-to-string
520    (lambda ()
521      (string-fold
522       (lambda (ch u)
523         (cond
524          ((char=? ch #\-) (display ch) #t)
525          (u (display (char-upcase ch)) #f)
526          (else (display ch) #f)))
527       #t h))))
528
529(define (rfc822-headers-write headers)
530  (for-each
531   (lambda (h)
532     (printf "~a: ~a\r\n"
533             (rfc822-header-upcase (car h))
534             (rfc822-header-fold (cadr h) (- 78 2 (string-length (car h))))))
535   headers))
536
537(define (alist-subst key value alist #!optional (test eqv?))
538  (let loop ((alist alist) (r '()) (f? #f))
539    (cond
540     ((null? alist)
541      (if f? (reverse r) (cons (cons key value) (reverse r))))
542     (f?
543      (loop (cdr alist) (cons (car alist) r) #t))
544     ((test key (caar alist))
545      (loop (cdr alist) (cons (cons (caar alist) value) r) #t))
546     (else
547      (loop (cdr alist) (cons (car alist) r) #f)))))
548
549(define (alist-subst* alist pairs #!optional (test eqv?))
550  (define (pairs-without pairs key)
551    (filter (lambda (x) (not (test (car x) key))) pairs))
552  (let loop ((alist alist) (r '()) (pairs pairs))
553    (cond
554     ((null? alist)
555      (append (reverse r) pairs))
556     ((null? pairs)
557      (loop (cdr alist) (cons (car alist) r) pairs))
558     ((assoc (caar alist) pairs test)
559      => (lambda (p) (loop (cdr alist) (cons (cons (caar alist) (cdr p)) r)
560                           (pairs-without pairs (car p)))))
561     (else
562      (loop (cdr alist) (cons (car alist) r) pairs)))))
563
564(define (content-type->string type subtype params)
565  (string-append
566   type "/"
567   subtype
568   (if (pair? params) ";" "")
569   (string-intersperse
570    (map (lambda (x) (string-append (car x) "=\"" (cdr x) "\"")) params)
571    ";")))
572
573(define (mime-part:modified-headers part #!optional new-boundary)
574  (alist-subst*
575   (mime-part:headers part)
576   `(("content-type"
577      ,(content-type->string
578        (mime-part:type part) (mime-part:subtype part)
579        (if new-boundary
580            (alist-subst "boundary" new-boundary (mime-part:parameters part) string-ci=?)
581            (mime-part:parameters part))))
582     ("content-transfer-encoding" ,(mime-part:transfer-encoding part)))
583   string=?))
584
585(define (multipart-write part #!optional boundary)
586  (let ((parts (map mime-part->string (mime-part:content part)))
587        (boundary (or boundary
588                      (alist-ref "boundary" (mime-part:parameters part) string-ci=?)
589                      "MIME-Message-Boundary-")))
590
591    (define (find-boundary)
592      (let loop ((boundary boundary)
593                 (parts parts))
594        (cond
595         ((null? parts) boundary)
596         ((string-contains (car parts) (string-append "--" boundary))
597          (loop (string-append boundary "a") parts))
598         (else
599          (loop boundary (cdr parts))))))
600
601    (let ((boundary (find-boundary)))
602
603      (define (write-boundary end?)
604        (display "\r\n--")
605        (display boundary)
606        (if end? (display "--\r\n") (display "\r\n")))
607
608      (rfc822-headers-write
609       (mime-part:modified-headers part boundary))
610      (display "\r\nThis message is in MIME format.\r\n")
611      (do ((parts parts (cdr parts)))
612          ((null? parts) (write-boundary #t))
613        (write-boundary #f)
614        (display (car parts))))))
615
616(define (message-write part)
617  (rfc822-headers-write (mime-part:modified-headers part))
618  (display "\r\n")
619  (mime-part-write (car (mime-part:content part))))
620
621(define (other-part-write part)
622  (define (write-base64)
623    (for-each
624     (lambda (s)
625       (display s)
626       (display "\r\n"))
627     (string-chop
628      (base64:encode (mime-part:content part))
629      76)))
630
631  (define (write-qp)
632    (with-input-from-string (mime-part:content part)
633      (lambda ()
634        (quoted-printable-encode
635         #:binary? (alist-ref 'qp-encode-binary?
636                              (mime-part:attrs part)
637                              eq? #f)))))
638
639  (rfc822-headers-write (mime-part:modified-headers part))
640  (display "\r\n")
641
642  (let ((enc (mime-part:transfer-encoding part)))
643    (cond
644     ((string-ci=? enc "base64")
645      (write-base64))
646     ((string-ci=? enc "quoted-printable")
647      (write-qp))
648     ((member enc '("7bit" "8bit" "binary") string-ci=?)
649      (display (mime-part:content part))))))
650
651
652(define (mime-part-write part)
653  (let ((type (mime-part:type part)))
654    (cond
655     ((string-ci=? type "multipart")
656      (multipart-write part))
657     ((string-ci=? type "message")
658      (message-write part))
659     (else
660      (other-part-write part)))))
661
662(define (mime-part->string part)
663  (with-output-to-string
664    (cut mime-part-write part)))
Note: See TracBrowser for help on using the repository browser.