diff options
Diffstat (limited to 'third_party/lisp/mime4cl/mime.lisp')
| -rw-r--r-- | third_party/lisp/mime4cl/mime.lisp | 172 |
1 files changed, 73 insertions, 99 deletions
diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp index eec7f87dfa..3cdac4b26b 100644 --- a/third_party/lisp/mime4cl/mime.lisp +++ b/third_party/lisp/mime4cl/mime.lisp @@ -1,7 +1,7 @@ ;;; mime4cl.lisp --- MIME primitives for Common Lisp ;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero -;;; Copyright (C) 2021 by the TVL Authors +;;; Copyright (C) 2021-2023 by the TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -183,14 +183,11 @@ :test #'string=) (mime= (mime-body part1) (mime-body part2)))) -(defun mime-body-stream (mime-part &key (binary t)) - (make-instance (if binary - 'binary-input-adapter-stream - 'character-input-adapter-stream) - :source (mime-body mime-part))) +(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) + (let ((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 @@ -207,8 +204,8 @@ while byte count byte)))))) -(defmacro with-input-from-mime-body-stream ((stream part &key (binary t)) &body forms) - `(with-open-stream (,stream (mime-body-stream ,part :binary ,binary)) +(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)) @@ -302,12 +299,13 @@ semi-colons not within strings or comments." (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) + ;; TODO(sterni): when-let + (let ((equal-position (position #\= string))) (when equal-position - (be key (subseq string 0 equal-position) + (let ((key (subseq string 0 equal-position))) (if (= equal-position (1- (length string))) (cons key "") - (be value (string-trim-whitespace (subseq string (1+ equal-position))) + (let ((value (string-trim-whitespace (subseq string (1+ equal-position))))) (cons key (if (and (> (length value) 1) (char= #\" (elt value 0))) @@ -316,8 +314,8 @@ semi-colons not within strings or comments." ;; reader (or (ignore-errors (read-from-string value)) (subseq value 1)) - (be end (or (position-if #'whitespace-p value) - (length value)) + (let ((end (or (position-if #'whitespace-p value) + (length value)))) (subseq value 0 end)))))))))) (defun parse-content-type (string) @@ -340,7 +338,7 @@ Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))." 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) + (let ((parts (split-header-parts string))) (cons (car parts) (mapcan #'(lambda (parameter-string) (awhen (parse-parameter parameter-string) (list it))) @@ -350,7 +348,7 @@ Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))." "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) + (let ((colon (position #\: string))) (when colon (values (string-trim-whitespace (subseq string 0 colon)) (string-trim-whitespace (subseq string (1+ colon))))))) @@ -419,34 +417,6 @@ each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY." do (last-part) do (process-line line))))) -;; This awkward handling of newlines is due to RFC2046: "The CRLF -;; preceding the boundary delimiter line is conceptually attached to -;; the boundary so that it is possible to have a part that does not -;; end with a CRLF (line break). Body parts that must be considered -;; to end with line breaks, therefore, must have two CRLFs preceding -;; the boundary delimiter line, the first of which is part of the -;; preceding body part, and the second of which is part of the -;; encapsulation boundary". -(defun split-multipart-parts (body-stream part-boundary) - "Read from BODY-STREAM and split MIME parts separated by -PART-BOUNDARY. Return a list of strings." - (let ((part (make-string-output-stream)) - (parts '()) - (beginning-of-part-p t)) - (flet ((output-line (line) - (if beginning-of-part-p - (setf beginning-of-part-p nil) - (terpri part)) - (write-string line part)) - (end-part () - (setf beginning-of-part-p t) - (push (get-output-stream-string part) parts))) - (do-multipart-parts body-stream part-boundary #'output-line #'end-part) - (close part) - ;; the first part is empty or contains all the junk - ;; to the first boundary - (cdr (nreverse parts))))) - (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." @@ -531,9 +501,9 @@ separated by PART-BOUNDARY." (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)))) + (let ((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)) @@ -588,7 +558,7 @@ found in STREAM." ;; 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) + for line = (let ((line (read-line stream nil))) ;; skip the Unix "From " header if present (if (string-starts-with "From " line) (read-line stream nil) @@ -641,19 +611,19 @@ found in STREAM." (defgeneric decode-mime-body (part input-stream)) -(defmethod decode-mime-body ((part mime-part) (stream delimited-input-stream)) - (be base (base-stream stream) - (if *lazy-mime-decode* - (setf (mime-body part) - (make-file-portion :data (etypecase base - (my-string-input-stream - (stream-string base)) - (file-stream - (pathname base))) - :encoding (mime-encoding part) - :start (file-position stream) - :end (stream-end stream))) - (call-next-method)))) +(defmethod decode-mime-body ((part mime-part) (stream flexi-stream)) + (let ((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* @@ -663,12 +633,12 @@ found in STREAM." :start (file-position stream))) (call-next-method))) -(defmethod decode-mime-body ((part mime-part) (stream my-string-input-stream)) +(defmethod decode-mime-body ((part mime-part) (stream vector-stream)) (if *lazy-mime-decode* (setf (mime-body part) - (make-file-portion :data (stream-string stream) + (make-file-portion :data (flexi-streams::vector-stream-vector stream) :encoding (mime-encoding part) - :start (file-position stream))) + :start (flexi-streams::vector-stream-index stream))) (call-next-method))) (defmethod decode-mime-body ((part mime-part) stream) @@ -679,19 +649,18 @@ found in 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)) + (let ((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-instance 'delimited-input-stream - :stream stream - :dont-close t - :start start - :end end) - (read-mime-part in)))) + (let ((*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) @@ -713,11 +682,11 @@ Return STRING itself if STRING is an unkown encoding." string)) (defun header (name headers) - (be elt (assoc name headers :test #'string-equal) + (let ((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) + (let ((entry (assoc name headers :test #'string-equal))) (unless entry (error "missing header ~A can't be set" name)) (setf (cdr entry) value))) @@ -729,7 +698,7 @@ guessed from the headers, use the *DEFAULT-TYPE*." (flet ((hdr (what) (header what headers))) (destructuring-bind (type subtype parms) - (or + (or (aand (hdr :content-type) (parse-content-type it)) *default-type*) @@ -755,16 +724,16 @@ guessed from the headers, use the *DEFAULT-TYPE*." (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)) + (let ((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"))) + (let ((headers (read-rfc822-headers stream)) + (*default-type* '("text" "plain" (("charset" . "us-ascii"))))) (flet ((hdr (what) (header what headers))) (destructuring-bind (type subtype parms) @@ -782,17 +751,21 @@ returns a MIME-MESSAGE object." msg) (defmethod mime-message ((msg string)) - (with-open-stream (in (make-instance 'my-string-input-stream :string msg)) - (read-mime-message in))) + (mime-message (flexi-streams:string-to-octets msg))) -(defmethod mime-message ((msg stream)) - (read-mime-message msg)) +(defmethod mime-message ((msg vector)) + (with-input-from-sequence (in msg) + (mime-message in))) (defmethod mime-message ((msg pathname)) - (let (#+sbcl(sb-impl::*default-external-format* :latin-1) - #+sbcl(sb-alien::*default-c-string-external-format* :latin-1)) - (with-open-file (in msg) - (read-mime-message in)))) + (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -815,15 +788,16 @@ returns a MIME-MESSAGE object." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod make-encoded-body-stream ((part mime-bodily-part)) - (be body (mime-body part) + (let ((body (mime-body part))) (make-instance (case (mime-encoding part) (:base64 'base64-encoder-input-stream) (:quoted-printable 'quoted-printable-encoder-input-stream) - (t + (otherwise '8bit-encoder-input-stream)) - :stream (make-instance 'binary-input-adapter-stream :source body)))) + :underlying-stream + (make-input-adapter body)))) (defun choose-boundary (parts &optional default) (labels ((match-in-parts (boundary parts) @@ -855,7 +829,7 @@ returns a MIME-MESSAGE object." ;; fall back method (defmethod mime-part-size ((part mime-part)) - (be body (mime-body part) + (let ((body (mime-body part))) (typecase body (pathname (file-size body)) @@ -882,7 +856,7 @@ returns a MIME-MESSAGE object." (case (mime-subtype part) (:alternative ;; try to choose something simple to print or the first thing - (be parts (mime-parts part) + (let ((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))) @@ -896,7 +870,7 @@ returns a MIME-MESSAGE object." ;; 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) + (let ((body (mime-body part))) (etypecase body (string (write-string body out)) @@ -950,8 +924,8 @@ second in MIME.")) (defmethod find-mime-part-by-path ((part mime-multipart) path) (if (null path) part - (be parts (mime-parts part) - part-number (car path) + (let ((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)." @@ -979,7 +953,7 @@ is a string.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod find-mime-text-part (msg) +(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.")) |