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

;;;
;;; mime.scm - parsing MIME (rfc2045) message
;;;  
;;;   Copyright (c) 2000-2004 Shiro Kawai, All rights reserved.
;;;   
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;   
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;  
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;  
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;  
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;  
;;;  $Id: mime.scm,v 1.11 2004/11/25 22:00:43 shirok Exp $
;;;
;;; Ported to Chicken by Hans Bulfone <jsb@nil.at>

;; RFC2045 Multipurpose Internet Mail Extensions (MIME)
;;  Part One: Format of Internet Message Bodies
;; RFC2046 Multipurpose Internet Mail Extensions (MIME)
;;  Part Two: Media Types
;; RFC2047 Multipurpose Internet Mail Extensions (MIME)
;;  Part Three: Message Header Extensions for Non-ASCII Text
;; RFC2048 
;; RFC2049 

(define-extension mime)
(declare
 (usual-integrations)
 (uses mime:quoted-printable)
 (export mime-parse-version mime-parse-content-type
         mime-decode-word
         mime-parse-message mime-retrieve-body
         mime-body->string mime-body->file
         make-mime-part mime-part?
         mime-part:type mime-part:subtype mime-part:parameters
         mime-part:transfer-encoding mime-part:parent mime-part:index
         mime-part:headers mime-part:content mime-part:attrs
         mime-part:type-set! mime-part:subtype-set! mime-part:parameters-set!
         mime-part:transfer-encoding-set! mime-part:parent-set! mime-part:index-set!
         mime-part:headers-set! mime-part:content-set! mime-part:attrs-set!
         mime-part-write mime-part->string))
(require-extension lolevel regex
                   srfi-1 srfi-13 srfi-14
                   rfc822  base64 iconv)

(define-macro (let1 name val . body)
  `(let ((,name ,val))
     ,@body))

;;===============================================================
;; Basic utility
;;

;; returns list of major and minor versions in integers
(define mime-parse-version
  (let ((re-version (regexp "^([0-9]+)\.([0-9]+)$")))
    (lambda (field)
      (and field
           (let1 s
               (string-concatenate (map ->string (rfc822-field->tokens field)))
             (cond ((string-search re-version s) =>
                    (lambda (m) (map (lambda (s) (string->number s)) (cdr m))))
                   (else #f)))))))

;; returns (<type> <subtype> (<attribute> . <value>) ...)
(define (mime-parse-content-type field)
  (define token-chars
    (char-set-difference
     (ucs-range->char-set #x21 #x7f)
     (char-set #\( #\) #\< #\> #\@ #\, #\; #\: #\\ #\" #\/ #\[ #\] #\? #\=)))
  (define cs-quote (char-set #\"))
  (define (get-attributes input r)
    (cond ((and-let* (((eqv? #\; (rfc822-next-token input '())))
                      (attr (rfc822-next-token input `(,token-chars)))
                      ((string? attr))
                      ((eqv? #\= (rfc822-next-token input '())))
                      (val  (rfc822-next-token
                             input
                             `(,token-chars
                               (,cs-quote . ,rfc822-quoted-string))))
                      ((string? val)))
             (cons attr val))
           => (lambda (p) (get-attributes input (cons p r))))
          (else (reverse! r))))

  (and field
       (call-with-input-string field
         (lambda (input)
           (let* ((type    (rfc822-next-token input `(,token-chars)))
                  (slash   (rfc822-next-token input '()))
                  (subtype (rfc822-next-token input `(,token-chars))))
             (and (string? type)
                  (eqv? #\/ slash)
                  (string? subtype)
                  (cons* (string-downcase type)
                         (string-downcase subtype)
                         (get-attributes input '()))))
           ))))

;; decode rfc2047-encoded word, i.e. "=?...?="
;; if word isn't legal encoded word, it is returned as is.
(define mime-decode-word
  (letrec
      ((re-word
        (regexp "^=\\?([-!#-'*+[:alnum:]^-~]+)\\?([-!#-'*+[:alnum:]^-~]+)\\?([!->@-~]+)\\?=$"))
;       (regexp "^=\\?([^? ]+)\\?([^? ]+)\\?([^? ]+)\\?=$"))
       ;; this is taken from alex shinn's charconv egg:
       (aliases (make-hash-table string=?))
       (ces-normalize-name
        (lambda (str)
          (let ((str2 (string-upcase str)))
            (hash-table-ref/default aliases str2 str2))))
       (%ces-upper-compatible?
        (lambda (a b)
          (cond
           ((not b) #t)
           ((string=? b "UTF8") (string=? a "UTF8"))
           ((string=? b "ASCII") (not (member a '("UTF16" "UTF32"))))
           (else #f))))
       (ces-upper-compatible?
        (lambda (a b)
          (%ces-upper-compatible? (ces-normalize-name a) (ces-normalize-name b))))
       (ces-convert
        (lambda (str from . o)
          (let ((to (or (and (pair? o) (car o)) "UTF8")))
            (if (ces-upper-compatible? to from)
                str
                (let ((cd (iconv-open to from)))
                  (iconv cd str)))))))

    (for-each
     (lambda (ls)
       (for-each
        (cute hash-table-set! aliases <> (car ls))
        (cdr ls)))
     '(("UTF8" "UTF-8")
       ("ISO-8859-1" "LATIN-1")
       ("SHIFT_JIS" "SJIS" "SHIFTJIS" "SHIFT-JIS")
       ("EUC-JP" "EUCJP" "EUC_JP")))

    (lambda (word)
      (cond
       ((string-search re-word word)
        => (match-lambda
            ((_ charset encoding body)
             (handle-exceptions
                 exn
                 word                   ; capture illegal encoding
               (cond
                ((string-ci=? encoding "q")
                 (ces-convert
                  (quoted-printable-decode-string body)
                  charset #f))
                ((string-ci=? encoding "b")
                 (ces-convert
                  (base64-decode-string body)
                  charset #f))
                (else word))))))        ; unsupported encoding
       (else word)))))


;;===============================================================
;; Virtual port to recognize mime boundary
;;

(define read-byte
  (let ((read-char read-char)
        (char->integer char->integer))
    (lambda (port)
      (let ((ch (read-char port)))
        (if (eof-object? ch)
            ch
            (char->integer ch))))))

(define peek-byte
  (let ((peek-char peek-char)
        (char->integer char->integer))
    (lambda (port)
      (let ((ch (peek-char port)))
        (if (eof-object? ch)
            ch
            (char->integer ch))))))

;; Creates a procedural port, which reads from SRCPORT until it reaches
;; either EOF or MIME boundary.  Basically it runs a DFA.
(define (make-mime-port boundary srcport)
  (define q (make-queue))
  (define (enqueue! queue . items)
    (if (null? items)
        (void)
        (begin
          (queue-add! queue (car items))
          (apply enqueue! queue (cdr items)))))
  (define dequeue! queue-remove!)
  (define --boundary (string->byte-vector (string-append "--" boundary)))

  (define state 'prologue)

  (define eof #!eof)

  (define (deq! q)
    (if (queue-empty? q) eof (dequeue! q)))
  
  (define (fifo! q b)
    (enqueue! q b) (dequeue! q))

  (define (getb)
    (if (queue-empty? q)
      (case state
        ((prologue) (skip-prologue))
        ((boundary eof) eof)
        (else (newb)))
      (dequeue! q)))

  (define (newb)
    (let1 b (read-byte srcport)
      (cond
       ((eof-object? b)
        (set! state 'eof)
        eof)
       (else
        (case b
          ((#x0d) ;; CR, check to see LF
           (let1 b2 (peek-byte srcport)
             (if (eqv? b2 #x0a)
               (begin
                 (read-byte srcport)
                 (enqueue! q b #x0a)
                 (check-boundary))
               b)))
          ((#x0a) ;; LF, check boundary
           (enqueue! q b) (check-boundary))
          (else b))))))

  (define (check-boundary)
    (let loop ((b   (peek-byte srcport))
               (ind 0)
               (max (byte-vector-length --boundary)))
      (cond ((eof-object? b)
             (deq! q))
            ((= ind max)
             (cond ((memv b '(#x0d #x0a)) ;;found boundary
                    (read-byte srcport)   ;;consume LF or CRLF
                    (when (and (eqv? #x0d b) 
                               (eqv? #x0a (peek-byte srcport)))
                      (read-byte srcport))
                    (set! q (make-queue))
                    (set! state 'boundary)
                    eof)
                   ((eqv? b #x2d) ;; maybe end boundary
                    (enqueue! q (read-byte srcport))
                    (cond ((eqv? (peek-byte srcport) #x2d);; yes, end boundary
                           (read-byte srcport)
                           (set! q (make-queue))
                           (skip-epilogue))
                          (else
                           (deq! q))))
                   (else
                    (deq! q))))
            ((= b (byte-vector-ref --boundary ind))
             (enqueue! q (read-byte srcport))
             (loop (peek-byte srcport) (+ ind 1) max))
            ((queue-empty? q)
             (newb))
            (else
             (dequeue! q)))))

  ;; Reads past the first boundary.  The first boundary may appear
  ;; at the beginning of the message (instead of after CRLF), so
  ;; we need slightly different handling than the normal getb.
  (define (skip-prologue)
    (let loop ((b (check-boundary)))
      (cond
       ((eof-object? b)
        (cond ((eq? state 'boundary) ; we've found the boundary
               (set! state 'body)
               (getb))
              (else                              ; no boundary found
               (set! state 'eof)
               eof)))
       ((queue-empty? q)
        (loop (newb)))
       (else
        (set! q (make-queue))
        (loop (newb))))))

  (define (skip-epilogue)
    (let loop ((b (read-byte srcport)))
      (if (eof-object? b)
        (begin (set! state 'eof)
               b)
        (loop (read-byte srcport)))))
  
  (values
   (make-input-port
    (lambda ()
      (let ((ch (getb)))
        (if (eof-object? ch)
            ch
            (integer->char ch))))
    (lambda ()
      (or (not (queue-empty? q))
          (char-ready? srcport)))
    void)
   (lambda () state)
   (lambda (s) (set! state s))))

;;===============================================================
;; Basic streaming parser
;;

(define-record-type :mime-part
  (*make-mime-part type subtype parameters transfer-encoding
                   parent index headers content attrs)
  mime-part?
  (type mime-part:type mime-part:type-set!)
  (subtype mime-part:subtype mime-part:subtype-set!)
  (parameters mime-part:parameters mime-part:parameters-set!)
  (transfer-encoding mime-part:transfer-encoding mime-part:transfer-encoding-set!)
  (parent mime-part:parent mime-part:parent-set!)
  (index mime-part:index mime-part:index-set!)
  (headers mime-part:headers mime-part:headers-set!)
  (content mime-part:content mime-part:content-set!)
  (attrs mime-part:attrs mime-part:attrs-set!))

(define (make-mime-part #!key (type "text") (subtype "plain")
                        (parameters '())
                        (transfer-encoding "7bit")
                        (parent #f) (index 0) (headers '())
                        (content #f) (attrs '()))
  (*make-mime-part type subtype parameters transfer-encoding
                   parent index headers content attrs))

(define (mime-parse-message port headers handler)
  (internal-parse port headers handler #f 0
                  '("text" "plain" ("charset" . "us-ascii"))))

(define (internal-parse port headers handler parent index default-type)
  (let* ((ctype (or (mime-parse-content-type
                     (rfc822-header-ref headers "content-type"))
                    default-type))
         (enc   (rfc822-header-ref headers "content-transfer-encoding" "7bit"))
         (packet (*make-mime-part
                  (car ctype) (cadr ctype) (cddr ctype)
                  enc parent index headers #f '()))
         )
    (cond
     ((equal? (car ctype) "multipart")
      (multipart-parse port packet handler))
     ((equal? (car ctype) "message")
      (message-parse port packet handler))
     (else
      ;; normal body
      (mime-part:content-set! packet (handler packet port))
      packet)
     )))

(define (multipart-parse port packet handler)
  (let ((boundary (or (alist-ref "boundary" (mime-part:parameters packet) equal?)
                      (error "No boundary given for multipart message")))
        (default-type (if (equal? (mime-part:subtype packet) "digest")
                          '("message" "rfc822")
                          '("text" "plain" ("charset" . "us-ascii")))))
    (receive (mime-port mime-port-state mime-port-state-set!)
        (make-mime-port boundary port)
      (let loop ((index 0)
                 (contents '()))
        (let* ((headers (rfc822-header->list mime-port))
               (r (internal-parse mime-port headers handler
                                  packet index
                                  default-type)))
          (case (mime-port-state)
            ((boundary)
             (mime-port-state-set! 'body)
             (loop (+ index 1) (cons r contents)))
            ((eof)
             (mime-part:content-set! packet (reverse! (cons r contents)))
             packet)
            (else
             ;; parser returned without readling entire part.
             ;; discard the rest of the part.
             (let loop ((b (read-char port)))
               (unless (eof-object? b)
                 (loop (read-char port))))
             packet)))))))

(define (message-parse port packet handler)
  (let* ((headers (rfc822-header->list port))
         (r (internal-parse port headers handler packet 0
                            '("text" "plain" ("charset" . "us-ascii")))))
    (mime-part:content-set! packet (list r)))
  packet)

;;===============================================================
;; Body readers
;;

(define (mime-retrieve-body packet inp outp)

  (define (read-line/nl)
    (let loop ((c (read-char inp))
               (chars '()))
      (cond ((eof-object? c)
             (if (null? chars)
               c
               (reverse-list->string chars)))
            ((char=? c #\newline)
             (reverse-list->string (cons c chars)))
            ((char=? c #\return)
             (let1 c (peek-char inp)
               (if (char=? c #\newline)
                   (reverse-list->string
                    (cons* (read-char inp) #\return chars))
                   (reverse-list->string (cons #\return chars)))))
            (else (loop (read-char inp) (cons c chars))))))
  
  (define (read-text decoder)
    (let loop ((line (read-line/nl)))
      (unless (eof-object? line)
        (display (decoder line) outp)
        (loop (read-line/nl)))))

  (define (read-base64)
    (display
     (base64:decode
      (with-output-to-string
        (lambda ()
          (let loop ((line (read-line inp)))
            (unless (eof-object? line)
              (display line)
              (loop (read-line inp)))))))
     outp))

  (let ((enc (mime-part:transfer-encoding packet)))
    (cond
     ((string-ci=? enc "base64") (read-base64))
     ((string-ci=? enc "quoted-printable")
      (read-text quoted-printable-decode-string))
     ((member enc '("7bit" "8bit" "binary") string-ci=?)
      (let loop ((b (read-char inp)))
        (unless (eof-object? b)
          (write-char b outp)
          (loop (read-char inp)))))
     ))
  )

(define (mime-body->string packet inp)
  (let ((s (open-output-string)))
    (mime-retrieve-body packet inp s)
    (get-output-string s)))

(define (mime-body->file packet inp filename)
  (call-with-output-file filename
    (lambda (outp)
      (mime-retrieve-body packet inp outp)))
  filename)


;;===============================================================
;; RFC2822/MIME message generator
;;

(define (rfc822-header-fold h #!optional (col 78))
  (define ws (char-set #\space #\tab))
  (define (fold-pos s)
    (let loop ((i (string-index s ws)) (p #f))
      (cond
       ((not i) p)
       ((= i 0)
        (loop (string-index s ws 1 (string-length s)) p))
       ((and (> i 0) (char=? (string-ref s (- i 1)) #\\))
        (loop (string-index s ws (+ i 1) (string-length s)) p))
;       ((> i 998) p)
       ((and p (> i col)) p)
       ((> i col) i)
       (else
        (loop (string-index s ws (+ i 1) (string-length s)) i)))))
  (define (fold1 s)
    (cond
     ((<= (string-length s) col)
      (display s) #f)
     ((fold-pos s)
      => (lambda (p)
           (display (substring s 0 p))
           (display "\r\n")
           (substring s p (string-length s))))
     (else
      ;; line is too long but we can't fold it (no whitespace)
      (display s) #f)))

  (if (string-any #\newline h)
      h
      (with-output-to-string
        (lambda ()
          (let loop ((h (fold1 h)))
            (if h (loop (fold1 h))))))))

(define (rfc822-header-upcase h)
  (with-output-to-string
    (lambda ()
      (string-fold
       (lambda (ch u)
         (cond
          ((char=? ch #\-) (display ch) #t)
          (u (display (char-upcase ch)) #f)
          (else (display ch) #f)))
       #t h))))

(define (rfc822-headers-write headers)
  (for-each
   (lambda (h)
     (printf "~a: ~a\r\n"
             (rfc822-header-upcase (car h))
             (rfc822-header-fold (cadr h) (- 78 2 (string-length (car h))))))
   headers))

(define (alist-subst key value alist #!optional (test eqv?))
  (let loop ((alist alist) (r '()) (f? #f))
    (cond
     ((null? alist)
      (if f? (reverse r) (cons (cons key value) (reverse r))))
     (f?
      (loop (cdr alist) (cons (car alist) r) #t))
     ((test key (caar alist))
      (loop (cdr alist) (cons (cons (caar alist) value) r) #t))
     (else
      (loop (cdr alist) (cons (car alist) r) #f)))))

(define (alist-subst* alist pairs #!optional (test eqv?))
  (define (pairs-without pairs key)
    (filter (lambda (x) (not (test (car x) key))) pairs))
  (let loop ((alist alist) (r '()) (pairs pairs))
    (cond
     ((null? alist)
      (append (reverse r) pairs))
     ((null? pairs)
      (loop (cdr alist) (cons (car alist) r) pairs))
     ((assoc (caar alist) pairs test)
      => (lambda (p) (loop (cdr alist) (cons (cons (caar alist) (cdr p)) r)
                           (pairs-without pairs (car p)))))
     (else
      (loop (cdr alist) (cons (car alist) r) pairs)))))

(define (content-type->string type subtype params)
  (string-append
   type "/"
   subtype
   (if (pair? params) ";" "")
   (string-intersperse
    (map (lambda (x) (string-append (car x) "=\"" (cdr x) "\"")) params)
    ";")))

(define (mime-part:modified-headers part #!optional new-boundary)
  (alist-subst*
   (mime-part:headers part)
   `(("content-type"
      ,(content-type->string
        (mime-part:type part) (mime-part:subtype part)
        (if new-boundary
            (alist-subst "boundary" new-boundary (mime-part:parameters part) string-ci=?)
            (mime-part:parameters part))))
     ("content-transfer-encoding" ,(mime-part:transfer-encoding part)))
   string=?))

(define (multipart-write part #!optional boundary)
  (let ((parts (map mime-part->string (mime-part:content part)))
        (boundary (or boundary
                      (alist-ref "boundary" (mime-part:parameters part) string-ci=?)
                      "MIME-Message-Boundary-")))

    (define (find-boundary)
      (let loop ((boundary boundary)
                 (parts parts))
        (cond
         ((null? parts) boundary)
         ((string-contains (car parts) (string-append "--" boundary))
          (loop (string-append boundary "a") parts))
         (else
          (loop boundary (cdr parts))))))

    (let ((boundary (find-boundary)))

      (define (write-boundary end?)
        (display "\r\n--")
        (display boundary)
        (if end? (display "--\r\n") (display "\r\n")))

      (rfc822-headers-write
       (mime-part:modified-headers part boundary))
      (display "\r\nThis message is in MIME format.\r\n")
      (do ((parts parts (cdr parts)))
          ((null? parts) (write-boundary #t))
        (write-boundary #f)
        (display (car parts))))))

(define (message-write part)
  (rfc822-headers-write (mime-part:modified-headers part))
  (display "\r\n")
  (mime-part-write (car (mime-part:content part))))

(define (other-part-write part)
  (define (write-base64)
    (for-each
     (lambda (s)
       (display s)
       (display "\r\n"))
     (string-chop
      (base64:encode (mime-part:content part))
      76)))

  (define (write-qp)
    (with-input-from-string (mime-part:content part)
      (lambda ()
        (quoted-printable-encode
         #:binary? (alist-ref 'qp-encode-binary?
                              (mime-part:attrs part)
                              eq? #f)))))

  (rfc822-headers-write (mime-part:modified-headers part))
  (display "\r\n")

  (let ((enc (mime-part:transfer-encoding part)))
    (cond
     ((string-ci=? enc "base64")
      (write-base64))
     ((string-ci=? enc "quoted-printable")
      (write-qp))
     ((member enc '("7bit" "8bit" "binary") string-ci=?)
      (display (mime-part:content part))))))


(define (mime-part-write part)
  (let ((type (mime-part:type part)))
    (cond
     ((string-ci=? type "multipart")
      (multipart-write part))
     ((string-ci=? type "message")
      (message-write part))
     (else
      (other-part-write part)))))

(define (mime-part->string part)
  (with-output-to-string
    (cut mime-part-write part)))