;;; mime4cl.lisp --- MIME primitives for Common Lisp
;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero
;;; Copyright (C) 2021 by the TVL Authors
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: mime4cl
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
(in-package :mime4cl)
(defclass mime-part ()
((subtype
:type (or string null)
:initarg :subtype
:accessor mime-subtype
;; some mime types don't require a subtype
:initform nil)
(type-parameters
:type list
:initarg :type-parameters
:initform '()
:accessor mime-type-parameters)
(version
:type (or string null)
:initarg :mime-version
:initform "1.0"
:accessor mime-version)
(id
:initform nil
:initarg :id
:reader mime-id)
(description
:initform nil
:initarg :description
:accessor mime-description)
(encoding
:initform :7bit
:initarg :encoding
:reader mime-encoding
:documentation
"It's supposed to be either:
:7BIT, :8BIT, :BINARY, :QUOTED-PRINTABLE, :BASE64, a
X-token or an ietf-token (whatever that means).")
(disposition
:type (or string null)
:initarg :disposition
:initform nil
:accessor mime-disposition)
(disposition-parameters
:type list
:initarg :disposition-parameters
:initform '()
:accessor mime-disposition-parameters))
(:documentation
"Abstract base class for all types of MIME parts."))
(defclass mime-bodily-part (mime-part)
((body
:initarg :body
:accessor mime-body))
(:documentation
"Abstract base class for MIME parts with a body."))
(defclass mime-unknown-part (mime-bodily-part)
((type
:initarg :type
:reader mime-type
:documentation
"The original type string from the MIME header."))
(:documentation
"MIME part unknown to this library. Accepted but not handled."))
(defclass mime-text (mime-bodily-part) ())
;; This turns out to be handy when making methods specialised
;; non-textual attachments.
(defclass mime-binary (mime-bodily-part) ())
(defclass mime-image (mime-binary) ())
(defclass mime-audio (mime-binary) ())
(defclass mime-video (mime-binary) ())
(defclass mime-application (mime-binary) ())
(defclass mime-multipart (mime-part)
((parts :initarg :parts
:accessor mime-parts)))
(defclass mime-message (mime-part)
((headers :initarg :headers
:initform '()
:type list
:accessor mime-message-headers)
(real-message :initarg :body
:accessor mime-body)))
(defun mime-part-p (object)
(typep object 'mime-part))
(defmethod initialize-instance ((part mime-multipart) &key &allow-other-keys)
(call-next-method)
;; The initialization argument of the PARTS slot of a mime-multipart
;; is expected to be a list of mime-parts. Thus, we implicitly
;; create the mime parts using the arguments found in this list.
(with-slots (parts) part
(when (slot-boundp part 'parts)
(setf parts
(mapcar #'(lambda (subpart)
(if (mime-part-p subpart)
subpart
(apply #'make-instance subpart)))
parts)))))
(defmethod initialize-instance ((part mime-message) &key &allow-other-keys)
(call-next-method)
;; Allow a list of mime parts to be specified as body of a
;; mime-message. In that case we implicitly create a mime-multipart
;; and assign to the body slot.
(with-slots (real-message) part
(when (and (slot-boundp part 'real-message)
(consp real-message))
(setf real-message
(make-instance 'mime-multipart :parts real-message)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun alist= (alist1 alist2 &key (test #'eql))
(null
(set-difference alist1 alist2
:test #'(lambda (x y)
(and (funcall test (car x) (car y))
(funcall test (cdr x) (cdr y)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric mime= (mime1 mime2)
(:documentation
"Return true if MIME1 and MIME2 have equivalent structure and identical bodies (as for EQ)."))
(defmethod mime= ((part1 mime-part) (part2 mime-part))
(macrolet ((null-or (compare x y)
`(or (and (not ,x)
(not ,y))
(and ,x ,y
(,compare ,x ,y))))
(cmp-slot (compare reader)
`(null-or ,compare (,reader part1) (,reader part2))))
(and (eq (class-of part1) (class-of part2))
(cmp-slot string-equal mime-subtype)
(alist= (mime-type-parameters part1)
(mime-type-parameters part2)
:test #'string-equal)
(cmp-slot string= mime-id)
(cmp-slot string= mime-description)
(cmp-slot eq mime-encoding)
(cmp-slot equal mime-disposition)
(alist= (mime-disposition-parameters part1)
(mime-disposition-parameters part2)
:test #'string-equal))))
(defmethod mime= ((part1 mime-multipart) (part2 mime-multipart))
(and (call-next-method)
(every #'mime= (mime-parts part1) (mime-parts part2))))
(defmethod mime= ((part1 mime-message) (part2 mime-message))
(and (call-next-method)
(alist= (mime-message-headers part1) (mime-message-headers part2)
:test #'string=)
(mime= (mime-body part1) (mime-body part2))))
(defun mime-body-stream (mime-part)
(make-input-adapter (mime-body mime-part)))
(defun mime-body-length (mime-part)
(be body (mime-body mime-part)
;; here the stream type is missing on purpose, because we may not
;; be able to size the length of a stream
(etypecase body
(string
(length body))
(vector
(length body))
(pathname
(file-size body))
(file-portion
(with-open-stream (in (open-decoded-file-portion body))
(loop
for byte = (read-byte in nil)
while byte
count byte))))))
(defmacro with-input-from-mime-body-stream ((stream part) &body forms)
`(with-open-stream (,stream (mime-body-stream ,part))
,@forms))
(defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part))
(and (call-next-method)
(with-input-from-mime-body-stream (in1 part1)
(with-input-from-mime-body-stream (in2 part2)
(loop
for b1 = (read-byte in1 nil)
for b2 = (read-byte in2 nil)
always (eq b1 b2)
while (and b1 b2))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric get-mime-type-parameter (part name)
(:documentation
"Return the MIME type parameter associated to NAME of PART."))
(defgeneric (setf get-mime-type-parameter) (value part name)
(:documentation
"Set the MIME type parameter associated to NAME of PART."))
(defmethod get-mime-type-parameter ((part mime-part) name)
(cdr (assoc name (mime-type-parameters part) :test #'string-equal)))
(defmethod (setf get-mime-type-parameter) (value part name)
(aif (assoc name (mime-type-parameters part) :test #'string-equal)
(setf (cdr it) value)
(push (cons name value)
(mime-type-parameters part)))
value)
(defgeneric get-mime-disposition-parameter (part name)
(:documentation
"Return the MIME disposition parameter associated to NAME of PART."))
(defmethod get-mime-disposition-parameter ((part mime-part) name)
(cdr (assoc name (mime-disposition-parameters part) :test #'string-equal)))
(defmethod (setf get-mime-disposition-parameter) (value part name)
(aif (assoc name (mime-disposition-parameters part) :test #'string-equal)
(setf (cdr it) value)
(push (cons name value)
(mime-disposition-parameters part))))
(defmethod mime-part-file-name ((part mime-part))
"Return the filename associated to mime PART or NIL if the mime
part doesn't have a file name."
(or (get-mime-disposition-parameter part :filename)
(get-mime-type-parameter part :name)))
(defmethod (setf mime-part-file-name) (value (part mime-part))
"Set the filename associated to mime PART."
(setf (get-mime-disposition-parameter part :filename) value
(get-mime-type-parameter part :name) value))
(defun mime-text-charset (part)
(get-mime-type-parameter part :charset))
(defun split-header-parts (string)
"Split parts of a MIME headers. These are divided by
semi-colons not within strings or comments."
(labels ((skip-comment (pos)
(loop
while (< pos (length string))
do (case (elt string pos)
(#\( (setf pos (skip-comment (1+ pos))))
(#\\ (incf pos 2))
(#\) (return (1+ pos)))
(otherwise (incf pos)))
finally (return pos)))
(skip-string (pos)
(loop
while (< pos (length string))
do (case (elt string pos)
(#\\ (incf pos 2))
(#\" (return (1+ pos)))
(otherwise (incf pos)))
finally (return pos))))
(loop
with start = 0 and i = 0 and parts = '()
while (< i (length string))
do (case (elt string i)
(#\; (push (subseq string start i) parts)
(setf start (incf i)))
(#\" (setf i (skip-string i)))
(#\( (setf i (skip-comment (1+ i))))
(otherwise (incf i)))
finally (return (mapcar #'string-trim-whitespace (nreverse (cons (subseq string start) parts)))))))
(defun parse-parameter (string)
"Given a string like \"foo=bar\" return a pair (\"foo\" .
\"bar\"). Return NIL if string is not parsable."
(be equal-position (position #\= string)
(when equal-position
(be key (subseq string 0 equal-position)
(if (= equal-position (1- (length string)))
(cons key "")
(be value (string-trim-whitespace (subseq string (1+ equal-position)))
(cons key
(if (and (> (length value) 1)
(char= #\" (elt value 0)))
;; the syntax of a RFC822 string is more or
;; less the same as the Lisp one: use the Lisp
;; reader
(or (ignore-errors (read-from-string value))
(subseq value 1))
(be end (or (position-if #'whitespace-p value)
(length value))
(subseq value 0 end))))))))))
(defun parse-content-type (string)
"Parse string as a Content-Type MIME header and return a list
of three elements. The first is the type, the second is the
subtype and the third is an alist of parameters and their values.
Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))."
(let* ((parts (split-header-parts string))
(content-type-string (car parts))
(slash (position #\/ content-type-string)))
;; You'd be amazed to know how many MUA can't produce an RFC
;; compliant message.
(when slash
(let ((type (subseq content-type-string 0 slash))
(subtype (subseq content-type-string (1+ slash))))
(list type subtype (remove nil (mapcar #'parse-parameter (cdr parts))))))))
(defun parse-content-disposition (string)
"Parse string as a Content-Disposition MIME header and return a
list. The first element is the layout, the other elements are
the optional parameters alist.
Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))."
(be parts (split-header-parts string)
(cons (car parts) (mapcan #'(lambda (parameter-string)
(awhen (parse-parameter parameter-string)
(list it)))
(cdr parts)))))
(defun parse-RFC822-header (string)
"Parse STRING which should be a valid RFC822 message header and
return two values: a string of the header name and a string of
the header value."
(be colon (position #\: string)
(when colon
(values (string-trim-whitespace (subseq string 0 colon))
(string-trim-whitespace (subseq string (1+ colon)))))))
(defvar *default-type* '("text" "plain" (("charset" . "us-ascii")))
"Internal special variable that contains the default MIME type at
any given time of the parsing phase. There are MIME container parts
that may change this.")
(defvar *mime-types*
'((:text mime-text)
(:image mime-image)
(:audio mime-audio)
(:video mime-video)
(:application mime-application)
(:multipart mime-multipart)
(:message mime-message)))
(defgeneric mime-part-size (part)
(:documentation
"Return the size in bytes of the body of a MIME part."))
(defgeneric print-mime-part (part stream)
(:documentation
"Output to STREAM one of the possible human-readable representation
of mime PART. Binary parts are omitted. This function can be used to
quote messages, for instance."))
(defun do-multipart-parts (body-stream part-boundary contents-function end-part-function)
"Read through BODY-STREAM. Call CONTENTS-FUNCTION at
each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY."
(let* ((boundary (s+ "--" part-boundary))
(boundary-length (length boundary)))
(labels ((output-line (line)
(funcall contents-function line))
(end-part ()
(funcall end-part-function))
(last-part ()
(end-part)
(return-from do-multipart-parts))
(process-line (line)
(cond ((not (string-starts-with boundary line))
;; normal line
(output-line line))
((and (= (length (string-trim-whitespace line))
(+ 2 boundary-length))
(string= "--" line :start2 boundary-length))
;; end of the last part
(last-part))
;; according to RFC2046 "the boundary may be followed
;; by zero or more characters of linear whitespace"
((= (length (string-trim-whitespace line)) boundary-length)
;; beginning of the next part
(end-part))
(t
;; the line boundary is followed by some
;; garbage; we treat it as a normal line
(output-line line)))))
(loop
for line = (read-line body-stream nil)
;; we should never reach the end of a proper multipart MIME
;; stream, but we don't want to be fooled by corrupted ones,
;; so we check for EOF
unless line
do (last-part)
do (process-line line)))))
(defun index-multipart-parts (body-stream part-boundary)
"Read from BODY-STREAM and return the file offset of the MIME parts
separated by PART-BOUNDARY."
(let ((parts '())
(start 0)
(len 0)
(beginning-of-part-p t))
(flet ((sum-chars (line)
(incf len (length line))
;; account for the #\newline
(if beginning-of-part-p
(setf beginning-of-part-p nil)
(incf len)))
(end-part ()
(setf beginning-of-part-p t)
(push (cons start (+ start len)) parts)
(setf start (file-position body-stream)
len 0)))
(do-multipart-parts body-stream part-boundary #'sum-chars #'end-part)
;; the first part is all the stuff up to the first boundary;
;; just junk
(cdr (nreverse parts)))))
(defgeneric encode-mime-part (part stream))
(defgeneric encode-mime-body (part stream))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun write-mime-header (part stream)
(when (mime-version part)
(format stream "~&MIME-Version: ~A~%" (mime-version part)))
(format stream "~&Content-Type: ~A~:{; ~A=~S~}~%" (mime-type-string part)
(mapcar #'(lambda (pair)
(list (car pair) (cdr pair)))
(mime-type-parameters part)))
(awhen (mime-encoding part)
(format stream "Content-Transfer-Encoding: ~A~%" it))
(awhen (mime-description part)
(format stream "Content-Description: ~A~%" it))
(when (mime-disposition part)
(format stream "Content-Disposition: ~A~:{; ~A=~S~}~%"
(mime-disposition part)
(mapcar #'(lambda (pair)
(list (car pair) (cdr pair)))
(mime-disposition-parameters part))))
(awhen (mime-id part)
(format stream "Content-ID: ~A~%" it))
(terpri stream))
(defmethod encode-mime-part ((part mime-part) stream)
(write-mime-header part stream)
(encode-mime-body part stream))
(defmethod encode-mime-part ((part mime-message) stream)
;; tricky: we have to mix the MIME headers with the message headers
(dolist (h (mime-message-headers part))
(unless (stringp (car h))
(setf (car h)
(string-capitalize (car h))))
(unless (or (string-starts-with "content-" (car h) #'string-equal)
(string-equal "mime-version" (car h)))
(format stream "~A: ~A~%"
(car h) (cdr h))))
(encode-mime-part (mime-body part) stream))
(defmethod encode-mime-part ((part mime-multipart) stream)
;; choose a boundary if not already set
(let* ((original-boundary (get-mime-type-parameter part :boundary))
(boundary (choose-boundary (mime-parts part) original-boundary)))
(unless (and original-boundary
(string= boundary original-boundary))
(setf (get-mime-type-parameter part :boundary) boundary))
(call-next-method)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod encode-mime-body ((part mime-part) stream)
(with-input-from-mime-body-stream (in part)
(encode-stream in stream (mime-encoding part))))
(defmethod encode-mime-body ((part mime-message) stream)
(encode-mime-body (mime-body part) stream))
(defmethod encode-mime-body ((part mime-multipart) stream)
(be boundary (or (get-mime-type-parameter part :boundary)
(setf (get-mime-type-parameter part :boundary)
(choose-boundary (mime-parts part))))
(dolist (p (mime-parts part))
(format stream "~%--~A~%" boundary)
(encode-mime-part p stream))
(format stream "~%--~A--~%" boundary)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun time-RFC822-string (&optional (epoch (get-universal-time)))
"Return a string describing the current time according to
the RFC822."
(multiple-value-bind (ss mm hh day month year week-day dst tz) (decode-universal-time epoch)
(declare (ignore dst))
(format nil "~A, ~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~:[-~;+~]~2,'0D~2,'0D"
(subseq (week-day->string week-day) 0 3)
day (subseq (month->string month) 0 3) (mod year 100) hh mm ss
(plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60))))
(defun parse-RFC822-date (date-string)
"Parse a RFC822 compliant date string and return an universal
time."
;; if we can't parse it, just return NIL
(ignore-errors
;; skip the optional DoW
(awhen (position #\, date-string)
(setf date-string (subseq date-string (1+ it))))
(destructuring-bind (day month year time &optional tz &rest rubbish)
(split-at '(#\space #\tab) date-string)
(declare (ignore rubbish))
(destructuring-bind (hh mm &optional ss) (split-string-at-char time #\:)
(encode-universal-time
(if ss
(read-from-string ss)
0)
(read-from-string mm)
(read-from-string hh)
(read-from-string day)
(1+ (position month
'("Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
:test #'string-equal))
(read-from-string year)
(when (and tz (or (char= #\+ (elt tz 0))
(char= #\- (elt tz 0))))
(/ (read-from-string tz) 100)))))))
(defun read-RFC822-headers (stream &optional required-headers)
"Read RFC822 compliant headers from STREAM and return them in a
alist of keyword and string pairs. REQUIRED-HEADERS is a list of
header names we are interested in; if NIL return all headers
found in STREAM."
;; the skip-header variable is to avoid the mistake of appending a
;; continuation line of a header we don't want to a header we want
(loop
with headers = '() and skip-header = nil
for line = (be line (read-line stream nil)
;; skip the Unix "From " header if present
(if (string-starts-with "From " line)
(read-line stream nil)
line))
then (read-line stream nil)
while (and line
(not (zerop (length line))))
do (if (whitespace-p (elt line 0))
(unless (or skip-header
(null headers))
(setf (cdar headers) (s+ (cdar headers) '(#\newline) line)))
(multiple-value-bind (name value) (parse-RFC822-header line)
;; the line contained rubbish instead of an header: we
;; play nice and return as we were at the end of the
;; headers
(unless name
(return (nreverse headers)))
(if (or (null required-headers)
(member name required-headers :test #'string-equal))
(progn
(push (cons name value) headers)
(setf skip-header nil))
(setf skip-header t))))
finally (return (nreverse headers))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric mime-message (thing)
(:documentation
"Convert THING to a MIME-MESSAGE object."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mime-message-header-values (name message &key decode)
"Return all values of the header with NAME in MESSAGE, optionally decoding
it according to RFC2047 if :DECODE is T."
(loop ;; A header may occur multiple times
for header in (mime-message-headers message)
;; MIME Headers should be case insensitive
;; https://stackoverflow.com/a/6143644
when (string-equal (car header) name)
collect (if decode
(decode-RFC2047 (cdr header))
(cdr header))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *lazy-mime-decode* t
"If true don't decode mime bodies in memory.")
(defgeneric decode-mime-body (part input-stream))
(defmethod decode-mime-body ((part mime-part) (stream flexi-stream))
(be base (flexi-stream-root-stream stream)
(if *lazy-mime-decode*
(setf (mime-body part)
(make-file-portion :data (etypecase base
(vector-stream
(flexi-streams::vector-stream-vector base))
(file-stream
(pathname base)))
:encoding (mime-encoding part)
:start (flexi-stream-position stream)
:end (flexi-stream-bound stream)))
(call-next-method))))
(defmethod decode-mime-body ((part mime-part) (stream file-stream))
(if *lazy-mime-decode*
(setf (mime-body part)
(make-file-portion :data (pathname stream)
:encoding (mime-encoding part)
:start (file-position stream)))
(call-next-method)))
(defmethod decode-mime-body ((part mime-part) (stream vector-stream))
(if *lazy-mime-decode*
(setf (mime-body part)
(make-file-portion :data (flexi-streams::vector-stream-vector stream)
:encoding (mime-encoding part)
:start (flexi-streams::vector-stream-index stream)))
(call-next-method)))
(defmethod decode-mime-body ((part mime-part) stream)
(setf (mime-body part)
(decode-stream-to-sequence stream (mime-encoding part))))
(defmethod decode-mime-body ((part mime-multipart) stream)
"Decode STREAM according to PART characteristics and return a
list of MIME parts."
(save-file-excursion (stream)
(be offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary))
(setf (mime-parts part)
(mapcar #'(lambda (p)
(destructuring-bind (start . end) p
(be *default-type* (if (eq :digest (mime-subtype part))
'("message" "rfc822" ())
'("text" "plain" (("charset" . "us-ascii"))))
in (make-positioned-flexi-input-stream stream
:position start
:bound end
:ignore-close t)
(read-mime-part in))))
offsets)))))
(defmethod decode-mime-body ((part mime-message) stream)
"Read from STREAM the body of PART. Return the decoded MIME
body."
(setf (mime-body part)
(read-mime-message stream)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64)
"List of known content encodings.")
(defun keywordify-encoding (string)
"Return a keyword for a content transfer encoding string.
Return STRING itself if STRING is an unkown encoding."
(aif (member string +known-encodings+ :test #'string-equal)
(car it)
string))
(defun header (name headers)
(be elt (assoc name headers :test #'string-equal)
(values (cdr elt) (car elt))))
(defun (setf header) (value name headers)
(be entry (assoc name headers :test #'string-equal)
(unless entry
(error "missing header ~A can't be set" name))
(setf (cdr entry) value)))
(defun make-mime-part (headers stream)
"Create a MIME-PART object based on HEADERS and a body which
has to be read from STREAM. If the mime part type can't be
guessed from the headers, use the *DEFAULT-TYPE*."
(flet ((hdr (what)
(header what headers)))
(destructuring-bind (type subtype parms)
(or
(aand (hdr :content-type)
(parse-content-type it))
*default-type*)
(let* ((class (or (cadr (assoc type *mime-types* :test #'string-equal))
'mime-unknown-part))
(disp (aif (hdr :content-disposition)
(parse-content-disposition it)
(values nil nil)))
(part (make-instance class
:type (hdr :content-type)
:subtype subtype
:type-parameters parms
:disposition (car disp)
:disposition-parameters (cdr disp)
:mime-version (hdr :mime-version)
:encoding (keywordify-encoding
(hdr :content-transfer-encoding))
:description (hdr :content-description)
:id (hdr :content-id)
:allow-other-keys t)))
(decode-mime-body part stream)
part))))
(defun read-mime-part (stream)
"Read mime part from STREAM. Return a MIME-PART object."
(be headers (read-rfc822-headers stream
'(:mime-version :content-transfer-encoding :content-type
:content-disposition :content-description :content-id))
(make-mime-part headers stream)))
(defun read-mime-message (stream)
"Main function to read a MIME message from a stream. It
returns a MIME-MESSAGE object."
(be headers (read-rfc822-headers stream)
*default-type* '("text" "plain" (("charset" . "us-ascii")))
(flet ((hdr (what)
(header what headers)))
(destructuring-bind (type subtype parms)
(or (aand (hdr :content-type)
(parse-content-type it))
*default-type*)
(declare (ignore type subtype))
(make-instance 'mime-message
:headers headers
;; this is just for easy access
:type-parameters parms
:body (make-mime-part headers stream))))))
(defmethod mime-message ((msg mime-message))
msg)
(defmethod mime-message ((msg string))
(mime-message (flexi-streams:string-to-octets msg)))
(defmethod mime-message ((msg vector))
(with-input-from-sequence (in msg)
(mime-message in)))
(defmethod mime-message ((msg pathname))
(with-open-file (in msg :element-type '(unsigned-byte 8))
(mime-message in)))
(defmethod mime-message ((msg flexi-stream))
(read-mime-message msg))
(defmethod mime-message ((msg stream))
(read-mime-message (make-flexi-stream msg)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric mime-part (object)
(:documentation
"Promote object, if necessary, to MIME-PART."))
(defmethod mime-part ((object string))
(make-instance 'mime-text :subtype "plain" :body object))
(defmethod mime-part ((object pathname))
(make-instance 'mime-application
:subtype "octect-stream"
:content-transfer-encoding :base64
:body (read-file object :element-type '(unsigned-byte 8))))
(defmethod mime-part ((object mime-part))
object)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod make-encoded-body-stream ((part mime-bodily-part))
(be body (mime-body part)
(make-instance (case (mime-encoding part)
(:base64
'base64-encoder-input-stream)
(:quoted-printable
'quoted-printable-encoder-input-stream)
(otherwise
'8bit-encoder-input-stream))
:underlying-stream
(make-input-adapter body))))
(defun choose-boundary (parts &optional default)
(labels ((match-in-parts (boundary parts)
(loop
for p in parts
thereis (typecase p
(mime-multipart
(match-in-parts boundary (mime-parts p)))
(mime-bodily-part
(match-in-body p boundary)))))
(match-in-body (part boundary)
(with-open-stream (in (make-encoded-body-stream part))
(loop
for line = (read-line in nil)
while line
when (string= line boundary)
return t
finally (return nil)))))
(do ((boundary (if default
(format nil "--~A" default)
#1=(format nil "--~{~36R~}"
(loop
for i from 0 below 20
collect (random 36))))
#1#))
((not (match-in-parts boundary parts)) (subseq boundary 2)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; fall back method
(defmethod mime-part-size ((part mime-part))
(be body (mime-body part)
(typecase body
(pathname
(file-size body))
(string
(length body))
(vector
(length body))
(t nil))))
(defmethod mime-part-size ((part mime-multipart))
(loop
for p in (mime-parts part)
for size = (mime-part-size p)
unless size
return nil
sum size))
(defmethod mime-part-size ((part mime-message))
(mime-part-size (mime-body part)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod print-mime-part ((part mime-multipart) (out stream))
(case (mime-subtype part)
(:alternative
;; try to choose something simple to print or the first thing
(be parts (mime-parts part)
(print-mime-part (or (find-if #'(lambda (part)
(and (eq (class-of part) (find-class 'mime-text))
(eq (mime-subtype part) :plain)))
parts)
(car parts)) out)))
(otherwise
(dolist (subpart (mime-parts part))
(print-mime-part subpart out)))))
;; This is WRONG. Here we don't use any special character encoding
;; because we don't know which one we should use. Messages written in
;; anything but ASCII will likely be unreadable -wcp11/10/07.
(defmethod print-mime-part ((part mime-text) (out stream))
(be body (mime-body part)
(etypecase body
(string
(write-string body out))
(vector
(loop
for byte across body
do (write-char (code-char byte) out)))
(pathname
(with-open-file (in body)
(loop
for c = (read-char in nil)
while c
do (write-char c out)))))))
(defmethod print-mime-part ((part mime-message) (out stream))
(flet ((hdr (name)
(multiple-value-bind (value tag)
(header name (mime-message-headers part))
(cons tag value))))
(dolist (h (mapcar #'hdr '("from" "subject" "to" "date" "x-march-archive-id")))
(when h
(format out "~&~A: ~A" (car h) (cdr h))))
(format out "~2%")
(print-mime-part (mime-body part) out)))
(defmethod print-mime-part ((part mime-part) (out stream))
(format out "~&[ ~A subtype=~A ~@[description=~S ~]~@[size=~A~] ]~%"
(type-of part) (mime-subtype part) (mime-description part) (mime-part-size part)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric find-mime-part-by-path (mime path)
(:documentation
"Return a subpart of MIME identified by PATH, which is a list of
integers. For example '(2 3 1) is the first part of the third of the
second in MIME."))
(defmethod find-mime-part-by-path ((part mime-part) path)
(if (null path)
part
(error "~S doesn't have subparts" part)))
(defmethod find-mime-part-by-path ((part mime-message) path)
(if (null path)
part
(if (= 1 (car path))
(find-mime-part-by-path (mime-body part) (cdr path))
(error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)."
part (car path)))))
(defmethod find-mime-part-by-path ((part mime-multipart) path)
(if (null path)
part
(be parts (mime-parts part)
part-number (car path)
(if (<= 1 part-number (length parts))
(find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path))
(error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)."
part (length parts) part-number)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric find-mime-part-by-id (part id)
(:documentation
"Return a subpart of PAR, whose Content-ID is the same as ID, which
is a string."))
(defmethod find-mime-part-by-id ((part mime-part) id)
(when (string= id (mime-id part))
part))
(defmethod find-mime-part-by-id ((part mime-message) id)
(find-mime-part-by-id (mime-body part) id))
(defmethod find-mime-part-by-id ((part mime-multipart) id)
(or (call-next-method)
(some #'(lambda (p)
(find-mime-part-by-id p id))
(mime-parts part))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric find-mime-text-part (msg)
(:documentation
"Return message if it is a text message or first text part.
If no suitable text part is found, return NIL."))
(defmethod find-mime-text-part ((part mime-text))
part) ; found our target
(defmethod find-mime-text-part ((msg mime-message))
;; mime-body is either a mime-part or mime-multipart
(find-mime-text-part (mime-body msg)))
(defmethod find-mime-text-part ((parts mime-multipart))
;; multipart messages may have a body, otherwise we
;; search for the first text part
(or (call-next-method)
(find-if #'find-mime-text-part (mime-parts parts))))
(defmethod find-mime-text-part ((part mime-part))
nil) ; default case
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric mime-type-string (mime-part)
(:documentation
"Return the string describing the MIME part."))
(defmethod mime-type-string ((part mime-unknown-part))
(mime-type part))
(defmethod mime-type-string ((part mime-text))
(format nil "text/~A" (mime-subtype part)))
(defmethod mime-type-string ((part mime-image))
(format nil "image/~A" (mime-subtype part)))
(defmethod mime-type-string ((part mime-audio))
(format nil "audio/~A" (mime-subtype part)))
(defmethod mime-type-string ((part mime-video))
(format nil "video/~A" (mime-subtype part)))
(defmethod mime-type-string ((part mime-application))
(format nil "application/~A" (mime-subtype part)))
(defmethod mime-type-string ((part mime-multipart))
(format nil "multipart/~A" (mime-subtype part)))
(defmethod mime-type-string ((part mime-message))
(format nil "message/~A" (mime-subtype part)))
(defmethod mime-type-string ((part mime-unknown-part))
(mime-type part))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric map-parts (function mime-part)
(:documentation
"Recursively map FUNCTION to MIME-PART or its components."))
;; Here we wrongly assume that we'll never want to replace messages
;; and multiparts altogether. If you need to do so you have to write
;; your own mapping functions.
(defmethod map-parts ((function function) (part mime-part))
(funcall function part))
(defmethod map-parts ((function function) (part mime-message))
(setf (mime-body part) (map-parts function (mime-body part)))
part)
(defmethod map-parts ((function function) (part mime-multipart))
(setf (mime-parts part) (mapcar #'(lambda (p)
(map-parts function p))
(mime-parts part)))
part)
;; apply-on-parts is like map-parts but doesn't modify the parts (at least
;; not implicitly)
(defgeneric apply-on-parts (function part))
(defmethod apply-on-parts ((function function) (part mime-part))
(funcall function part))
(defmethod apply-on-parts ((function function) (part mime-multipart))
(dolist (p (mime-parts part))
(apply-on-parts function p)))
(defmethod apply-on-parts ((function function) (part mime-message))
(apply-on-parts function (mime-body part)))
(defmacro do-parts ((var mime-part) &body body)
`(apply-on-parts #'(lambda (,var) ,@body) ,mime-part))
