mime-parse.cl

;; -*- mode: common-lisp; package: net.post-office -*-
;;
;; See the file LICENSE for the full license governing this code.
;;

(defpackage :net.post-office
  (:use #:lisp #:excl)
  (:export
   #:parse-mime-structure
   #:mime-dequote
   #:with-part-stream
   
   ;; accessors
   #:mime-part-headers-size
   #:mime-part-body-size
   #:mime-part-lines
   #:mime-part-position
   #:mime-part-body-position
   #:mime-part-message

   ;; class name
   #:mime-part-parsed
   
   ))

(in-package :net.post-office)

(eval-when (compile)
  (declaim (optimize (speed 3))))

(eval-when (compile load eval)
  (require :streamp))

;;; MIME structure parser.
;;; Ref: RFC2045/2046

(defclass mime-part-parsed (mime-part)
  (
   (headers-size ;; in bytes. Includes the bytes for the blank line
    :accessor mime-part-headers-size :initform nil)
   (body-size ;; in bytes.
    :accessor mime-part-body-size :initform nil)
   (lines ;; line count of body (for non-multipart types)
    :accessor mime-part-lines :initform nil)
   (position ;; file position of start of headers
    :accessor mime-part-position :initform nil)
   (body-position ;; file position of start of body
    :accessor mime-part-body-position :initform nil)
   (message ;; for message/rfc822 encapsulated message.  
    ;; This will be a mime-part
    :accessor mime-part-message :initform nil)))

(defmacro get-header (name headers)
  `(cdr (assoc ,name ,headers :test #'equalp)))

(defvar *mime-read-line-unread*)

(defun parse-mime-structure (stream &key mbox)
  (let ((*mime-read-line-unread* nil))
    (multiple-value-bind (part stop-reason newpos)
	(parse-mime-structure-1 stream nil nil 0 mbox :outer t)
      (when (and part mbox (not (eq stop-reason :eof)))
	;;(format t "advancing to next mbox boundary~%")
	(multiple-value-bind (x y z newpos2)
	    (read-until-boundary stream nil newpos t)
	  (declare (ignore x y z))
	  (setf stop-reason :eof)
	  (setf newpos newpos2)))
      (values part stop-reason newpos))))

;; Returns values:
;; 1) The part (or nil if EOF while reading readers)
;; 2) The stop reason (:eof, :close-boundary, nil (meaning regular boundary))
;; 3) The new position

;: mime-parse-message-rfc822, parse-mime-structure, mime-parse-multipart
;: 
(defun parse-mime-structure-1 (stream boundary digest pos mbox &key outer)
  (let ((part (make-instance 'mime-part-parsed)))
    (setf (mime-part-position part) pos)
    (setf (mime-part-boundary part) boundary)
    (multiple-value-bind (headers bytes)
	(parse-headers stream mbox)
      (if (and (null headers) outer)
	  (return-from parse-mime-structure-1))
      (setf (mime-part-headers-size part) bytes)
      (incf pos bytes)
      (setf (mime-part-body-position part) pos)
      (setf (mime-part-headers part) headers)
      
      (let ((content-type (get-header "content-type" headers)))
	(setf (mime-part-id part) (get-header "Content-Id" headers))
	(setf (mime-part-description part) 
	  (get-header "Content-description" headers))
	(setf (mime-part-encoding part) 
	  (or (get-header "Content-transfer-encoding" headers)
	      "7bit"))
	
	(multiple-value-bind (type subtype params)
	    (parse-content-type content-type)
	  
	  (if* (null type)
	     then (if* digest
		     then (setf (mime-part-type part) "message")
			  (setf (mime-part-subtype part) "rfc822")
			  (setf (mime-part-parameters part) 
			    '(("charset" . "us-ascii")))
			  (mime-parse-message-rfc822 part stream boundary pos
						     mbox)
		     else (setup-text-plain-part part stream boundary pos 
						 mbox))
	     else (setf (mime-part-type part) type)
		  (setf (mime-part-subtype part) subtype)
		  (setf (mime-part-parameters part) params)
		  
		  (cond 
		   ((equalp type "multipart")
		    (mime-parse-multipart part stream boundary pos 
					  mbox))
		   ((message-rfc822-p type subtype)
		    (mime-parse-message-rfc822 part stream boundary pos 
					       mbox))
		   (t
		    (mime-parse-non-multipart part stream boundary pos 
					      mbox)))))))))

;: skip-whitespace, parse-header-line, parse-headers
;: 
(defmacro whitespace-char-p (char)
  (let ((c (gensym)))
    `(let ((,c ,char))
       (or (char= ,c #\space) (char= ,c #\tab) (char= ,c #\newline)))))

;; OK if 'string' is nil.
;; Might return nil
;; called by parse-mime-structure-1
;: parse-mime-structure-1
;: 
(defun parse-content-type (string)
  (block nil
    (if (null string)
	(return))
    (let ((max (length string))
	  pos type subtype)
      (multiple-value-setq (type pos)
	(mime-get-token string 0 max))
      (if (string= type "")
	  (return))
      
      (setf pos (skip-whitespace string pos max))
      
      (if (or (>= pos max) (char/= (schar string pos) #\/))
	  (return)) ;; bogus input
      
      (multiple-value-setq (subtype pos)
	(mime-get-token string (1+ pos) max))
      
      (if (string= subtype "")
	  (return)) ;; bogus input
      
      (values type subtype (parse-parameters string pos max)))))





;; called by parse-content-type.
;: parse-content-type
;: 
(defun parse-parameters (string pos max)
  (let (char pairs param value)
    (while (< pos max)
      (setf pos (skip-whitespace string pos max))
      (setf char (schar string pos))
      
      (if (char/= char #\;)
	  (return))
      
      (multiple-value-setq (param pos)
	(mime-get-token string (1+ pos) max))
      (setf pos (skip-whitespace string pos max))
      (if (or (>= pos max) (char/= (schar string pos) #\=))
	  (return))
      (multiple-value-setq (value pos)
	(mime-get-parameter-value string (1+ pos) max))

      (push (cons param value) pairs))
    (values (nreverse pairs) pos)))
  

(defconstant *mime-tspecials*
    '(#\( #\) #\< #\> #\@ 
      #\, #\; #\: #\\ #\" 
      #\/ #\[ #\] #\? #\=))

;: parse-content-type, parse-parameters, mime-get-parameter-value
;: mime-get-token, blank-line-p, parse-header-line
;: 
(defun skip-whitespace (string pos max)
  (declare (optimize (speed 3) (safety 0))
	   (fixnum pos max))
  (while (< pos max)
    (if (not (whitespace-char-p (schar string pos)))
	(return))
    (incf pos))
  pos)

;: parse-parameters
;: 
(defun mime-get-parameter-value (string pos max)
  (setf pos (skip-whitespace string pos max))
  (if* (>= pos max)
     then (values "" pos)
     else (if (char= (schar string pos) #\")
	      (mime-get-quoted-string string pos max)
	    (mime-get-token string pos max))))

;: parse-content-type, parse-parameters, mime-get-parameter-value
;: 
(defun mime-get-token (string pos max)
  (setf pos (skip-whitespace string pos max))
  (let ((startpos pos)
	char)
    (while (< pos max)
      (setf char (schar string pos))
      (if (or (char= #\space char) (member char *mime-tspecials*))
	  (return))
      (incf pos))
    (values (subseq string startpos pos) pos)))

;; Doesn't attempt to dequote
;: mime-get-parameter-value
;: 
(defun mime-get-quoted-string (string pos max)
  (let ((res (make-string (- max pos)))
	(outpos 0)
	char inquote inbackslash)
    (while (< pos max)
      (setf char (schar string pos))
      
      (when (and (char= char #\") (not inbackslash))
	(if* inquote
	   then	(setf (schar res outpos) char)
		(incf outpos)
		(incf pos)
		(return))
	(setf inquote t))
      
      (if* inbackslash
	 then (setf inbackslash nil)
	 else (if (char= char #\\)
		  (setf inbackslash t)))
      
      (setf (schar res outpos) char)
      (incf outpos)
      (incf pos))
    
    (values (subseq res 0 outpos) pos)))

;; mime-parse-multipart
;: 
(defun mime-dequote (string)
  (block nil
    (if (or (string= string "") (char/= (schar string 0) #\"))
	(return string))
    
    (let* ((max (length string))
	   (pos 1)
	   (res (make-string max))
	   (outpos 0)
	   char inbackslash)
      
      (while (< pos max)
	(setf char (schar string pos))
	
	(if (and (char= char #\") (not inbackslash))
	    (return))
	
	(if* (and (not inbackslash) (char= char #\\))
	   then	(setf inbackslash t)
		(incf pos)
	   else	(setf (schar res outpos) char)
		(incf outpos)
		(incf pos)
		(setf inbackslash nil)))
      
      (subseq res 0 outpos))))

;: parse-mime-structure-1
;: 
(defun setup-text-plain-part (part stream boundary pos mbox)
  (setf (mime-part-type part) "text")
  (setf (mime-part-subtype part) "plain")
  (setf (mime-part-parameters part) '(("charset" . "us-ascii")))
  (mime-parse-non-multipart part stream boundary pos mbox))

;: setup-text-plain-part, parse-mime-structure-1
;: 
(defun mime-parse-non-multipart (part stream boundary pos mbox)
  (let ((startpos pos))
    (multiple-value-bind (size lines eof pos)
	(read-until-boundary stream boundary pos mbox)
      
      (setf (mime-part-lines part) lines)
      (setf (mime-part-body-position part) startpos)
      (setf (mime-part-body-size part) size)
      
      (values part eof pos))))

;: parse-mime-structure-1
;: 
(defun mime-parse-message-rfc822 (part stream boundary pos mbox)
  (let ((startpos pos))
    (multiple-value-bind (message eof pos)
	(parse-mime-structure-1 stream boundary nil pos mbox)
      
      (setf (mime-part-message part) message)
      
      (setf (mime-part-body-position part) startpos)
      (setf (mime-part-body-size part) (- pos startpos))
      
      (values part eof pos))))
  

;: parse-mime-structure-1
;: 
(defun mime-parse-multipart (part stream parent-boundary pos mbox)
  (let* ((params (mime-part-parameters part))
	 (boundary (cdr (assoc "boundary" params :test #'equalp)))
	 (startpos pos)
	 parts eof newpart)
    
    (setf (mime-part-boundary part) parent-boundary)
    
    ;; If boundary isn't specified.. try to compensate by using our
    ;; parent's boundary.
    (if* (null boundary)
       then (setf boundary parent-boundary)
       else (setf boundary (mime-dequote boundary)))

    ;; Locate the first boundary.
    (multiple-value-bind (ignore1 ignore2 ignore3 newpos)
	(read-until-boundary stream boundary pos mbox)
      (declare (ignore ignore1 ignore2 ignore3))
      (setf pos newpos))
    
    (until eof
      (multiple-value-setq (newpart eof pos)
	(parse-mime-structure-1 stream boundary
				(equalp (mime-part-subtype part) "digest")
				pos mbox))
      (push newpart parts))
    
    (setf (mime-part-parts part) (nreverse parts))
    
    (setf (mime-part-body-size part) (- pos startpos))
    
    ;; Discard everything that follows until we reach the parent-boundary.
    (multiple-value-bind (ignore1 ignore2 eof pos)
	(read-until-boundary stream parent-boundary pos mbox)
      (declare (ignore ignore1 ignore2))
      (values part eof pos))))


;; support

(defconstant *whitespace* '(#\space #\tab #\return #\newline))


;: parse-headers
;: 
(defun parse-header-line (line len)
  (declare (optimize (speed 3) (safety 0)))
  (let ((pos 0)
	colonpos
	spacepos)
    (declare (fixnum len pos spacepos))
    
    (while (< pos len)
      (let ((char (schar line pos))) 
	(when (char= char #\:)
	  (setf colonpos pos)
	  (return))
	
	(if (and (null spacepos) (whitespace-char-p char))
	    (setf spacepos pos)))
      
      (incf pos))
 
    (if (null colonpos) ;; bogus header line
	(return-from parse-header-line))
    
    (if (null spacepos)
	(setf spacepos colonpos))
    
    (if (= 0 spacepos) ;; bogus header line (no name)
	(return-from parse-header-line))
    
    (values (subseq line 0 spacepos)
	    (subseq line (skip-whitespace line (1+ colonpos) len) len))))

;; Returns offset of end of line in buffer.  Or nil if EOF
;; Second value is the number of characters read (including EOL chars)

;: parse-headers, read-until-boundary, collect-message-data-from-mbox
;: 
(defun mime-read-line (stream buffer)
  (declare (optimize (speed 3) (safety 0)))
  
  (if* *mime-read-line-unread*
     then (let* ((line (car *mime-read-line-unread*))
		 (bytes (cdr *mime-read-line-unread*))
		 (len (length line)))
	    (declare (simple-string line))
	    (setf *mime-read-line-unread* nil)
	    (dotimes (n len)
	      (setf (schar buffer n) (schar line n)))
	    (values len bytes))
     else (let ((pos 0)
		(end (length buffer))
		(count 0)
		char)
	    (declare (fixnum pos end count))
    
	    (while (and (< pos end) (setf char (read-char stream nil nil)))
	      (incf count)
	      (if (char= char #\newline)
		  (return))
	      (setf (schar buffer pos) char)
	      (incf pos))
    
	    (if* (= count 0)
	       then nil ;; EOF
	       else ;; Check for CR/LF combo
		    (if (and (> pos 0) 
			     (char= (schar buffer (1- pos)) #\return))
			(decf pos))
		    
		    (values pos count)))))
	    
(defun mime-unread-line (line end bytes)
  ;; This should never happen
  (if *mime-read-line-unread*
      (error "Unread buffer is full."))
  (setf *mime-read-line-unread* 
    (cons (subseq line 0 end) bytes)))

(eval-when (compile)
  (defconstant *parse-headers-line-len* 1024))

;; Returns:
;; 1) headers alist
;; 2) # of characters composing the header and terminator.
;:
;: parse-mime-structure-1
;: 
(defun parse-headers (stream mbox)
  (declare (optimize (speed 3) (safety 0)))
  (let ((count 0)
	(line (make-array #.*parse-headers-line-len* :element-type 'character))
	headers lastcons current incomplete lastincomplete)
    (declare (fixnum count)
	     (dynamic-extent line))

    (loop
      (multiple-value-bind (end bytes)
	  (mime-read-line stream line)
	(declare (fixnum end bytes))

	(if (null end)  ;; EOF
	    (return))
	
	(setf incomplete (= end #.*parse-headers-line-len*))
	
	(if (and mbox (not lastincomplete) (my-prefixp "From " line end))
	    (return))
	
	(incf count bytes)

	(cond
	 (lastincomplete ;; rest of a long line
	  (setf (car lastcons)
	    (concatenate 'string (car lastcons) (subseq line 0 end))))
	 
	 ((zerop end) ;; blank line
	  (return))
	 
	 ((whitespace-char-p (schar line 0)) ;; Continuation line
	  (when (null current) ;; Malformed header line
	    (decf count bytes) 
	    (mime-unread-line line end bytes)
	    (return)) 
	  
	  (let ((newcons (cons (subseq line 0 end) nil)))
	    (setf (cdr lastcons) newcons)
	    (setf lastcons newcons)))

	 (t ;; Fresh header line
	  (multiple-value-bind (name value)
	      (parse-header-line line end)
	    (when (null name)
	      ;; Malformed header line.  Unread it (so that it
	      ;; will be treated as part of the body) and
	      ;; consider the headers terminated.
	      (decf count bytes)
	      (mime-unread-line line end bytes)
	      (return))
	    
	    (setf lastcons (cons value nil))
	    (setf current (cons name lastcons))
	    (push current headers))))
	 
	(setf lastincomplete incomplete)))

    ;; Finalize strings.
    (dolist (header headers)
      (setf (cdr header) (coalesce-header header)))
    
    (values (nreverse headers) count)))

;: parse-headers
;: 
(defun coalesce-header (header)
  (declare (optimize (speed 3) (safety 0)))
  (let ((stringlist (cdr header)))
    (if* (= (length stringlist) 1)
       then (first stringlist)
       else (let ((len 0))
	      (declare (fixnum len))
	      (dolist (string stringlist)
		(incf len (1+ (the fixnum (length string)))))
	      (decf len)
	      (let ((res (make-string len))
		    (pos 0)
		    (first t))
		(declare (fixnum pos))
		(dolist (string stringlist)
		  (if* first
		     then (setf first nil)
		     else (setf (schar res pos) #\newline)
			  (incf pos))
		  (dotimes (n (length string))
		    (declare (fixnum n))
		    (setf (schar res pos) (schar string n))
		    (incf pos)))
		res)))))

;; Returns: (1) size of part 
;;          (2) number of lines read
;;          (3) stop reason (:eof, :close-boundary, or nil (meaning regular
;;                                                          boundary)
;;          (4) new stream position (post boundary read)
;: mime-parse-multipart, mime-parse-non-multipart
;: 
(defun read-until-boundary (stream boundary pos mbox)
  (declare (optimize (speed 3) (safety 0))
	   (fixnum pos))
  (if* (and (null boundary) (null mbox))
     then 
	  (multiple-value-bind (lines count)
	      (count-lines-to-eof stream)
	    (declare (fixnum count))
	    (values count lines :eof (+ pos count)))
     else 
	  (let ((line (make-array 16000 :element-type 'character))
		(size 0)
		(lines 0)
		(stop-reason :eof)
		delimiter close-delimiter)
	    (declare (dynamic-extent line)
		     (fixnum size lines))
	    
	    (when boundary
	      (setf delimiter (concatenate 'string "--" boundary))
	      (setf close-delimiter (concatenate 'string delimiter "--")))
	    
	    (loop
	      (multiple-value-bind (end bytes)
		  (mime-read-line stream line)
		(declare (fixnum end bytes))
		
		(if (or (null end)
			(and mbox (my-prefixp "From " line end)))
		    (return))
		
		(incf pos bytes)
		
		(when (and delimiter (my-prefixp delimiter line end))
		  (if* (my-prefixp close-delimiter line end)
		     then (setf stop-reason :close-boundary)
		     else (setf stop-reason nil))
		  (return))
		
		(incf size bytes)
		(incf lines))) 
	    
	    (values size lines stop-reason pos))))

;; Returns:
;; 1) number of lines
;; 2) number of bytes read
;: read-until-boundary
;: 
(defun count-lines-to-eof (stream)
  (declare (optimize (speed 3) (safety 0)))
  (let ((buffer (make-array 65536 :element-type '(unsigned-byte 8)))
	(lines 0)
	(pos 0)
	(lastbyte -1)
	(count 0)
	end)
    (declare (dynamic-extent buffer)
	     (fixnum lines pos end lastbyte count))
    ;; count 10's
    ;; XXX: The count will be off if the file has CR/LF convention and
    ;; there are bare LFs.  
    (loop
      (setf end (read-vector buffer stream))
      (incf count end)
      
      (if (= end 0)
	  (return))
      
      (while (< pos end)
	(if (= (aref buffer pos) 10)
	    (incf lines))
	(incf pos))
      
      (setf lastbyte (aref buffer (1- pos))))
    
    ;; Count last partial line.
    (if (and (> lastbyte 0) (/= lastbyte 10))
	(incf lines))
    
    (values lines count)))

(defun my-prefixp (prefix string &optional end)
  (declare (optimize (speed 3) (safety 0)))
  (let ((lenprefix (length prefix))
	(end (or end (length string))))
    (declare (fixnum lenprefix end))
    (when (>= end lenprefix)
      (dotimes (n lenprefix)
	(declare (fixnum n))
	(if (char/= (schar prefix n) (schar string n))
	    (return-from my-prefixp)))
      t)))

;;; misc

(defun stream-to-stream-copy (outstream instream count)
  (declare (optimize (speed 3))
	   (fixnum count))
  (let ((buf (make-array 4096 :element-type '(unsigned-byte 8))))
    (declare (dynamic-extent buf))
    (while (> count 0)
      (let ((got (read-sequence buf instream :end (min count 4096))))
	(declare (fixnum got))
	(if (zerop got)
	    (error "Unexpected EOF while reading from ~a" instream))
	(write-sequence buf outstream :end got)
	(decf count got)))))

;; 'instream' must be positioned appropriately by the caller beforehand.
(defmacro with-part-stream ((sym part instream &key (header t)) &body body)
  (let ((p (gensym))
	(stream (gensym))
	(count (gensym)))
    `(let* ((,p ,part)
	    (,stream ,instream)
	    (,count (mime-part-body-size ,p)))
       (if ,header
	   (incf ,count (mime-part-headers-size ,p)))
       (excl:with-function-input-stream 
	   (,sym #'stream-to-stream-copy ,stream ,count)
	 ,@body))))
	 


;;; testing

#|
(defun test-parse-mime (file &key (pretty t))
  (with-open-file (f file)
    (let ((res     (parse-mime-structure f)))
      (if pretty
	  (pprint-rfc822-part res)
	res))))

(defun pprint-rfc822-part (thing &optional (prefix ""))
  (if (null thing)
      (error "Strange. something called pprint-rfc822-part with nil"))
  (let ((type (mime-part-type thing))
	(subtype (mime-part-subtype thing)))
    (format t "~AHEADER ([RFC-2822] header of the message)~%" prefix)
    (format t "~ATEXT   ([RFC-2822] text body of the message) ~A/~A~%" prefix type subtype)
    
    (if* (message-rfc822-p type subtype)
       then ;; XXX .. what should the new prefix be? 
	    (pprint-rfc822-part (mime-part-message thing) prefix)
     elseif (equalp type "multipart")
       then (pprint-multipart thing prefix))))

(defun pprint-multipart (thing prefix)
  (let ((id 1))
    (dolist (part (mime-part-parts thing))
      (let ((type (mime-part-type part))
	    (subtype (mime-part-subtype part)))
	(format t "~a~a      ~a/~a~%" prefix id type subtype)
	(if* (message-rfc822-p type subtype)
	   then (pprint-rfc822-part (mime-part-message part) 
				    (format nil "~a~a." prefix id))
	 elseif (equalp type "multipart")
	   then (pprint-multipart part (format nil "~a~a." prefix id)))
	(incf id)))))
|#