@@ -34,7 +34,7 @@ v2: make-mime-part: Default external-format is :utf8."

 ;; merchantability or fitness for a particular purpose.  See the GNU

 ;; Lesser General Public License for more details.

 ;;

-;; $Id: mime-api.cl,v 1.6 2007/04/17 22:01:42 layer Exp $

+;; $Id: mime-api.cl,v 1.7 2007/05/31 23:13:08 dancy Exp $

 (defpackage :net.post-office

   (:use #:lisp #:excl)

@@ -45,6 +45,7 @@ v2: make-mime-part: Default external-format is :utf8."

    #:mime-part-p

    #:mime-part-constructed-p

    #:map-over-parts

+   #:decode-header-text

    ;; macros

    #:mime-get-header

@@ -362,6 +363,77 @@ This is a multi-part message in MIME format.~%"))

    elseif (message-rfc822-p (mime-part-type part) (mime-part-subtype part))

      then (map-over-parts (mime-part-message part) function)))

+(defparameter *charset-to-ef*

+    '(("shift-jis" . :shiftjis)

+      ("us-ascii" . :latin1)

+      ("gbk" . :936)

+      #+ignore("euc-kr" :iso-2022-kr)

+      ))

+

+(defun charset-to-external-format (charset)

+  (setf charset (string-downcase charset))

+  (block nil

+    (let ((ef (find-external-format charset :errorp nil)))

+      (if ef

+	  (return ef))

+      (if (setf ef (cdr (assoc charset *charset-to-ef* :test #'string=)))

+	  (return (find-external-format ef)))

+      (multiple-value-bind (matched x inner)

+	  (match-re "^windows-(\\d+)$" charset)

+	(declare (ignore x))

+	(if (and matched (setf ef (find-external-format inner :errorp nil)))

+	    (return ef)))

+      (multiple-value-bind (matched x dig)

+	  (match-re "^iso-8859-(\\d+)(?:-[ie])?$" charset)

+	(declare (ignore x))

+	(if (and matched (setf ef (find-external-format (format nil "iso8859-~a" dig) :errorp nil)))

+	    (return ef)))

+

+      nil)))

+

+(defun decode-header-text (text)

+  (declare (optimize (speed 3))

+	   (string text))

+  (let ((pos 0)

+	(len (length text)))

+    (declare (fixnum pos len))

+    (with-output-to-string (res)

+      (while (< pos len)

+	(multiple-value-bind (matched whole charset encoding encoded)

+	    (match-re "=\\?([^?]+)\\?(q|b)\\?(.*?)\\?=" text 

+		      :start pos

+		      :case-fold t

+		      :return :index)

+	  

+	  (if (null matched)

+	      (return))

+	  

+	  ;; Write out the "before" stuff.

+	  (write-string text res :start pos :end (car whole))

+	  

+	  (let* ((charset (subseq text (car charset) (cdr charset)))

+		 (ef (charset-to-external-format charset)))

+	    (if (null ef)

+		(error "No external format found for MIME charset ~s" charset))

+	    (write-string 

+	     (if* (char-equal (char text (car encoding)) #\q)

+		then (qp-decode-string text

+				       :start (car encoded)

+				       :end (cdr encoded)

+				       :external-format ef)

+		else ;; FIXME: Clean this up with/if rfe6174 is completed.

+		     (octets-to-string

+		      (base64-string-to-usb8-array 

+		       (subseq text (car encoded) (cdr encoded)))

+		      :external-format ef))

+	     res))

+	  

+	  (setf pos (cdr whole))))

+	  

+      ;; Write out the remaining portion.

+      (write-string text res :start pos))))

+

+

 ;; Stuff ripped off from aserve

 (defun split-namestring (file)

@@ -14,7 +14,7 @@

 ;; merchantability or fitness for a particular purpose.  See the GNU

 ;; Lesser General Public License for more details.

 ;;

-;; $Id: mime-parse.cl,v 1.5 2007/05/29 18:25:50 layer Exp $

+;; $Id: mime-parse.cl,v 1.6 2007/05/31 23:13:08 dancy Exp $

 (defpackage :net.post-office

   (:use #:lisp #:excl)

@@ -66,22 +66,36 @@

 (defmacro get-header (name headers)

   `(cdr (assoc ,name ,headers :test #'equalp)))

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

+

 (defun parse-mime-structure (stream &key mbox)

-  (parse-mime-structure-1 stream nil nil 0 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

+;; 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)

+(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)

@@ -367,13 +381,6 @@

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

-;: parse-headers

-;: 

-(defun blank-line-p (line len)

-  (declare (optimize (speed 3) (safety 0))

-	   (fixnum len))

-  (= len (skip-whitespace line 0 len)))

-

 ;: parse-headers

 ;: 

 (defun parse-header-line (line len)

@@ -414,27 +421,47 @@

 ;: 

 (defun mime-read-line (stream buffer)

   (declare (optimize (speed 3) (safety 0)))

-  (let ((pos 0)

-	(end (length buffer))

-	(count 0)

-	char)

-    (declare (fixnum pos end count))

+  

+  (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))

+	    (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))))

+	    (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

@@ -445,10 +472,8 @@

 (defun parse-headers (stream mbox)

   (declare (optimize (speed 3) (safety 0)))

   (let ((count 0)

-	(line (make-array 1024 :element-type 'character))

-	headers 

-	lastcons

-	current)

+	(line (make-array #.*parse-headers-line-len* :element-type 'character))

+	headers lastcons current incomplete lastincomplete)

     (declare (fixnum count)

 	     (dynamic-extent line))

@@ -456,34 +481,48 @@

       (multiple-value-bind (end bytes)

 	  (mime-read-line stream line)

 	(declare (fixnum end))

-	

-	(if (or (null end)

-		(and mbox (my-prefixp "From " line end)))

-	    (return))

-	(incf count bytes)

+	(if (null end)  ;; EOF

+	    (return))

-	(if (blank-line-p line end)

+	(setf incomplete (= end #.*parse-headers-line-len*))

+	

+	(if (and mbox (not lastincomplete) (my-prefixp "From " line end))

 	    (return))

-	(if* (whitespace-char-p (schar line 0))

-	   then ;; Continuation line

-		(if (null current)

-		    (return)) 

-	      

-		(let ((newcons (cons (subseq line 0 end) nil)))

-		  (setf (cdr lastcons) newcons)

-		  (setf lastcons newcons))

-	      

-	   else ;; Fresh header line

-		(multiple-value-bind (name value)

-		    (parse-header-line line end)

-		  (if (null name)

-		      (return)) 

-		

-		  (setf lastcons (cons value nil))

-		  (setf current (cons name lastcons))

-		  (push current headers)))))

+	(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

+	  (if (null current) ;; Malformed header line

+	      (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.

+	      (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)

@@ -558,7 +597,7 @@

 		(incf pos bytes)

-		(when (my-prefixp delimiter line end)

+		(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))

@@ -14,7 +14,7 @@

 ;; merchantability or fitness for a particular purpose.  See the GNU

 ;; Lesser General Public License for more details.

 ;;

-;; $Id: mime-transfer-encoding.cl,v 1.9 2007/04/17 22:01:42 layer Exp $

+;; $Id: mime-transfer-encoding.cl,v 1.10 2007/05/31 23:13:08 dancy Exp $

 (defpackage :net.post-office

   (:use #:lisp #:excl)

@@ -28,6 +28,8 @@

    #:base64-decode-stream

    #:qp-encode-stream

    #:qp-decode-stream

+   #:qp-decode-usb8

+   #:qp-decode-string

    #:with-decoded-part-body-stream))

 (in-package :net.post-office)

@@ -126,7 +128,6 @@

 	(setf (aref arr 256) -2)

 	arr))

-

 (defun qp-decode-stream (instream outstream &key count)

   (declare (optimize (speed 3)))

@@ -184,6 +185,96 @@

 	t))))

+;; 'out' should be at least the size of 'in'.  If it is nil,

+;; a usb8 array will be allocated and used.   It is okay if 'out' is the

+;; same buffer as 'in'.

+;; Returns:

+;;  1) the supplied or allocated array

+;;  2) the just past the last byte populated in the array.

+(defun qp-decode-usb8 (in out &key (start1 0) (end1 (length in))

+				   (start2 0) end2)

+  (declare (optimize (speed 3))

+	   ((simple-array (unsigned-byte 8) (*)) in out)

+	   (fixnum start1 end1 start2 end2))

+  

+  (if (null out)

+      (setf out (make-array (length in) :element-type '(unsigned-byte 8))))

+  

+  (if (null end2)

+      (setf end2 (length out)))

+  

+  (let ((count (- end1 start1)))

+    (declare (fixnum count))

+    

+    (if (< count 0)

+	(error "start1 must be less than end1"))

+    

+    (if (> start2 end2)

+	(error "start2 must be less than end2"))

+    

+    (if (< (the fixnum (- end2 start2)) count)

+	(error "Not enough room in output array"))

+    

+    (macrolet ((unread (byte)

+		 (declare (ignore byte))

+		 `(decf start1))

+	       (get-byte (&key eof-value)

+		 `(if* (>= start1 end1)

+		     then ,eof-value

+		     else (prog1 (aref in start1)

+			    (incf start1))))

+	       (out (byte)

+		 `(prog1 (setf (aref out start2) ,byte)

+		    (incf start2)))

+	       (eol-p (byte)

+		 `(or (eq ,byte 10) (eq ,byte 13))))

+	       

+      (let (byte)

+	(while (setf byte (get-byte))

+	  (if* (eq byte #.(char-code #\=))

+	     then (let ((nextbyte (get-byte)))

+		    (if* (null nextbyte)

+		       then ;; stray equal sign.  just dump and terminate.

+			    (out byte)

+			    (return))

+		    (if* (eol-p nextbyte)

+		       then ;; soft line break.  

+			    (if (eq nextbyte 13) ;; CR

+				(setf nextbyte (get-byte)))

+			    (if (not (eq nextbyte 10)) ;; LF

+				(unread nextbyte))

+		       else ;; =XY encoding

+			    (let* ((byte3 (get-byte :eof-value 256))

+				   (high (aref *qp-digit-values* nextbyte))

+				   (low (aref *qp-digit-values* byte3))

+				   (value (logior (the fixnum (ash high 4)) low)))

+			      (declare (fixnum byte3 high low value))

+			      (if* (< value 0)

+				 then ;; Invalid or truncated encoding. just dump it.

+				      (out byte)

+				      (out nextbyte)

+				      (if* (eq low -2) ;; EOF

+					 then (return)

+					 else (out byte3))

+				 else (out value)))))

+	     else (out byte)))

+	

+	(values out start2)))))

+

+(defun qp-decode-string (string &key (start 0) (end (length string))

+				     (return :string)

+				     (external-format :default))

+  (multiple-value-bind (vec len)

+      (string-to-octets string :start start :end end :null-terminate nil

+			:external-format :latin1)

+    (multiple-value-setq (vec len)

+      (qp-decode-usb8 vec vec :end1 len))

+    (ecase return

+      (:string

+       (octets-to-string vec :end len :external-format external-format))

+      (:usb8

+       (subseq vec 0 len)))))

+

 ;; 'instream' must be positioned at the beginning of the part body 

 ;; by the caller beforehand.

 (defmacro with-decoded-part-body-stream ((sym part instream) &body body)

@@ -14,7 +14,7 @@

 ;; merchantability or fitness for a particular purpose.  See the GNU

 ;; Lesser General Public License for more details.

 ;;

-;; $Id: rfc2822.cl,v 1.3 2007/04/17 22:01:42 layer Exp $

+;; $Id: rfc2822.cl,v 1.4 2007/05/31 23:13:08 dancy Exp $

 #+(version= 8 0)

 (sys:defpatch "rfc2822" 0

@@ -98,33 +98,161 @@ domain.

 |#

 (eval-when (compile eval)

-  ;; dash at the end to avoid mistaking it for a character range

-  ;; indicator.

-  (defconstant *atext-chars*

-      "!#$%&'*+/0123456789=?ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`abcdefghijklmnopqrstuvwxyz{|}~-")

+  (defconstant *controls* "\\x0-\\x1f")

-  (defconstant *dot-atom* 

-      (format nil "[~a]+(\\.[~a]+)*" *atext-chars* *atext-chars*))

+  (defconstant *specials* "()<>\\[\\]:;@\\,.\"")

+  

+  (defconstant *no-ws-ctl* "\\x1-\\x8\\xb-\\xc\\xe-\\x1f\\x7f")

+  

+  (defconstant *fws* "(?:(?:[ \\t]*\\r?\\n)?[ \\t]+)")

-  (defconstant *dotted-dot-atom* 

-      (format nil "[~a]+(\\.[~a]+)+"  *atext-chars* *atext-chars*))

+  (defconstant *text* "[^\\r\\n]")

-  (defvar *rfc822-dotted-domain-re*

-      (format nil "^(~a)(@(~a))?$" *dot-atom* *dotted-dot-atom*))

+  (defconstant *quoted-pair* (format nil "\\\\~a" *text*))

-  (defvar *rfc822-re* (format nil "^(~a)(@(~a))?$" *dot-atom* *dot-atom*))

-  )

+  (defconstant *ctext* "[^\\s()\\\\]")

+

+  ;; 1 means (xx)

+  ;; 2 means (xxx (yyy) zzz)

+  (defconstant *max-comment-level* 2)

+  

+  (defparameter *ccontent nil)

+  (defparameter *comment* nil)

+  

+  (dotimes (n *max-comment-level*)

+    (if* (null *comment*)

+       then (setf *ccontent* (format nil "(?:~a|~a)" *ctext* *quoted-pair*))

+       else (setf *ccontent* (format nil "(?:~a|~a|~a)" 

+				     *ctext* *quoted-pair* *comment*)))

+    

+    (setf *comment* (format nil "\\((?:~a?~a)*~a?\\)"

+			    *fws* *ccontent* *fws*)))

+  

+  (defconstant *cfws* (format nil "(?:~a?~a)*(?:(?:~a?~a)|~a)"

+			      *fws* *comment* *fws* *comment* *fws*))

+  

+  (defconstant *atext* 

+      (format nil "[^\\s~a~a]" *controls* *specials*))

+  

+  (defconstant *atom* (format nil "~a?(~a+)~a?" *cfws* *atext* *cfws*))

+

+  (defconstant *dot-atom-text* (format nil "~a+(?:\\.~a+)*" *atext* *atext*))

+  

+  (defconstant *dot-atom* (format nil "~a?(~a)~a?" 

+				  *cfws* *dot-atom-text* *cfws*))

+  

+  ;; no control chars, no backslash, no quote

+  (defconstant *qtext* (format nil "[^~a\\\\\"]" *controls*))

+  

+  (defconstant *qcontent* (format nil "~a|~a" *qtext* *quoted-pair*))

+  (defconstant *quoted-string*

+      (format nil "~a?\"((?:~a?~a)*~a?)\"~a?"

+	      *cfws* *fws* *qcontent* *fws* *cfws*))

+  

+  (defconstant *local-part* 

+      (format nil "(~a)|(~a)" *dot-atom* *quoted-string*))

+  

+  ;; domain literals not supported.

+  (defconstant *domain* *dot-atom*)

+  

+  (defconstant *addr-spec* (format nil "(~a)@(~a)" *local-part* *domain*))

+  

+  (defconstant *angle-addr* (format nil "~a?<~a>~a?" 

+				    *cfws* *addr-spec* *cfws*))

+  

+  (defconstant *word* (format nil "(?:~a|~a)" *atom* *quoted-string*))

+  

+  (defconstant *phrase* (format nil "~a+" *word*))

+  

+  (defconstant *display-name* *phrase*)

+  

+  (defconstant *name-addr* (format nil "~a?~a" *display-name* *angle-addr*))

+  

+  (defconstant *mailbox* (format nil "(?:~a|~a)" *name-addr* *addr-spec*))

+  

+  (defconstant *mailbox-list* 

+      (format nil "(?:~a(?:,~a)*)" *mailbox* *mailbox*))

+

+  (defconstant *group* 

+      (format nil "~a:(?:~a|~a)?;~a?" *display-name* *mailbox-list* *cfws*

+	      *cfws*))

+  

+  ;; More strict than the RFC.

+  

+  (defconstant *email-address-re*

+      (format nil "^\\s*(~a)(?:@(~a))?\\s*$" *dot-atom-text* *dot-atom-text*))

+  

+  )

+      

 (defun parse-email-address (string &key (require-domain t)

 					(require-dotted-domain t))

-  (multiple-value-bind (matched whole user dummy1 dummy2 domain)

-      (if* require-dotted-domain

-	 then (match-re #.*rfc822-dotted-domain-re* string)

-	 else (match-re #.*rfc822-re* string))

-    (declare (ignore whole dummy1 dummy2))

-    (if (or (not matched) (and require-domain (null domain)))

-	nil

-      (values user domain))))

+  (multiple-value-bind (matched x user domain)

+      (match-re #.*email-address-re* string)

+    (declare (ignore x))

+    (if* (or 

+	  ;; Failure cases

+	  (not matched) 

+	  (and require-domain (null domain))

+	  (and require-dotted-domain domain (zerop (count #\. domain))))

+       then nil

+       else (values user domain))))

+

+;; Returns a list of entries like so: 

+;;  (:mailbox user domain display-name)

+;;  or

+;;  (:group display-name mailbox-list)

+

+(defun extract-email-addresses (string &key (start 0) (end (length string))

+					    (errorp t))

+  )

+

+(defmacro parse-common (re)

+  (let ((matched (gensym))

+	(whole (gensym))

+	(inner (gensym)))

+    (setf re (format nil "^~a" (symbol-value re)))

+    `(multiple-value-bind (,matched ,whole, inner)

+	 (match-re ,re string :start start :end end :return :index)

+       (when ,matched

+	 (values (subseq string (car ,inner) (cdr ,inner))

+		 (cdr ,whole))))))

+

+;; Domain literals not supported

+;; local-part @ domain ==>

+;; dot-atom/quoted-string @ dot-atom

+;; Optionally allows domain-less addrspecs.  However, doing so

+;; makes parsing ambiguous.

+(defun parse-addr-spec (string start end require-domain)

+  (declare (optimize (speed 3))

+	   (fixnum start end))

+  (block nil

+    (multiple-value-bind (local-part newpos)

+	(parse-local-part string start end)

+      (if (null local-part)

+	  (return))

+      (setf start newpos)

+      (when (or (eq start end)

+		(not (eq (char string start) #\@)))

+	;; no domain part.

+	(if* require-domain

+	   then (return)

+	   else (return (values local-part nil start))))

+      (incf start)

+      (multiple-value-bind (domain newpos)

+	  (parse-common *dot-atom*)

+	(if domain

+	    (values local-part domain newpos))))))

+

+(defun parse-local-part (string &optional (start 0) (end (length string)))

+  (multiple-value-bind (dot-atom newpos)

+      (parse-common *dot-atom*)

+    (if* dot-atom

+       then (values dot-atom newpos)

+       else (multiple-value-bind (quoted-string newpos)

+		(parse-common *quoted-string*)

+	      (when quoted-string

+		(values quoted-string newpos))))))

 ;; Ripped from maild:dns.cl and modified.