about summary refs log tree commit diff
path: root/third_party/lisp/mime4cl/streams.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/mime4cl/streams.lisp')
-rw-r--r--third_party/lisp/mime4cl/streams.lisp274
1 files changed, 274 insertions, 0 deletions
diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp
new file mode 100644
index 000000000000..71a32d84e461
--- /dev/null
+++ b/third_party/lisp/mime4cl/streams.lisp
@@ -0,0 +1,274 @@
+;;; streams.lisp --- En/De-coding Streams
+
+;;; Copyright (C) 2012 by Walter C. Pelissero
+;;; Copyright (C) 2021-2023 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)
+
+(defun flexi-stream-root-stream (stream)
+  "Return the non FLEXI-STREAM stream a given chain of FLEXI-STREAMs is based on."
+  (if (typep stream 'flexi-stream)
+      (flexi-stream-root-stream (flexi-stream-stream stream))
+      stream))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass coder-stream-mixin ()
+  ((real-stream :type stream
+                :initarg :underlying-stream
+                :reader real-stream)
+   (dont-close :initform nil
+               :initarg :dont-close)))
+
+(defmethod stream-file-position ((stream coder-stream-mixin))
+  (file-position (slot-value stream 'real-stream)))
+
+(defmethod (setf stream-file-position) (newval (stream coder-stream-mixin))
+  (file-position (slot-value stream 'real-stream) newval))
+
+(defclass coder-input-stream-mixin (fundamental-binary-input-stream coder-stream-mixin)
+  ())
+(defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin)
+  ())
+
+;; TODO(sterni): temporary, ugly measure to make flexi-streams happy
+(defmethod stream-element-type ((stream coder-input-stream-mixin))
+  (declare (ignore stream))
+  '(unsigned-byte 8))
+
+(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ())
+(defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ())
+
+(defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ())
+(defclass base64-encoder-stream (coder-output-stream-mixin base64-encoder) ())
+(defclass 8bit-encoder-stream (coder-output-stream-mixin 8bit-encoder) ())
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys)
+  (unless (slot-boundp stream 'real-stream)
+    (error "REAL-STREAM is unbound.  Must provide a :UNDERLYING-STREAM argument.")))
+
+(defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys)
+  (call-next-method)
+  (unless (slot-boundp stream 'output-function)
+    (setf (slot-value stream 'output-function)
+          #'(lambda (char)
+              (write-char char (slot-value stream 'real-stream))))))
+
+(defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys)
+  (call-next-method)
+  (unless (slot-boundp stream 'input-function)
+    (setf (slot-value stream 'input-function)
+          #'(lambda ()
+              (read-char (slot-value stream 'real-stream) nil)))))
+
+(defmethod stream-read-byte ((stream coder-input-stream-mixin))
+  (or (decoder-read-byte stream)
+      :eof))
+
+(defmethod stream-write-byte ((stream coder-output-stream-mixin) byte)
+  (encoder-write-byte stream byte))
+
+(defmethod close ((stream coder-stream-mixin) &key abort)
+  (with-slots (real-stream dont-close) stream
+    (unless dont-close
+      (close real-stream :abort abort))))
+
+(defmethod close ((stream coder-output-stream-mixin) &key abort)
+  (unless abort
+    (encoder-finish-output stream))
+  (call-next-method))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass encoder-input-stream (fundamental-character-input-stream coder-stream-mixin)
+  ((encoder)
+   (buffer-queue :initform (make-queue)))
+  (:documentation
+   "This is the base class for encoders with the direction swapped. It
+reads from REAL-STREAM a stream of bytes, encodes it and returnes it
+in a stream of character."))
+
+(defclass quoted-printable-encoder-input-stream (encoder-input-stream) ())
+(defclass base64-encoder-input-stream (encoder-input-stream) ())
+(defclass 8bit-encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) ())
+
+(defmethod initialize-instance ((stream quoted-printable-encoder-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (with-slots (encoder buffer-queue) stream
+    (setf encoder
+          (make-instance 'quoted-printable-encoder
+                         :output-function #'(lambda (char)
+                                              (queue-append buffer-queue char))))))
+
+(defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (with-slots (encoder buffer-queue) stream
+    (setf encoder
+          (make-instance 'base64-encoder
+                         :output-function #'(lambda (char)
+                                              (queue-append buffer-queue char))))))
+
+(defmethod stream-read-char ((stream encoder-input-stream))
+  (with-slots (encoder buffer-queue real-stream) stream
+    (loop
+       while (queue-empty-p buffer-queue)
+       do (let ((byte (read-byte real-stream nil)))
+            (if byte
+                (encoder-write-byte encoder byte)
+                (progn
+                  (encoder-finish-output encoder)
+                  (queue-append buffer-queue :eof)))))
+    (queue-pop buffer-queue)))
+
+
+(defmethod stream-read-char ((stream 8bit-encoder-input-stream))
+  (with-slots (real-stream) stream
+    (aif (read-byte real-stream nil)
+         (code-char it)
+         :eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun make-custom-flexi-stream (class stream other-args)
+  (apply #'make-instance
+         class
+         :stream stream
+         (mapcar (lambda (x)
+                   ;; make-flexi-stream has a discrepancy between :initarg of
+                   ;; make-instance and its &key which we mirror here.
+                   (if (eq x :external-format) :flexi-stream-external-format x))
+                 other-args)))
+
+(defclass adapter-flexi-input-stream (flexi-input-stream)
+  ((ignore-close
+    :initform nil
+    :initarg :ignore-close
+    :documentation
+    "If T, calling CLOSE on the stream does nothing.
+If NIL, the underlying stream is closed."))
+  (:documentation "FLEXI-STREAM that does not close the underlying stream on
+CLOSE if :IGNORE-CLOSE is T."))
+
+(defmethod close ((stream adapter-flexi-input-stream) &key abort)
+  (declare (ignore abort))
+  (with-slots (ignore-close) stream
+    (unless ignore-close
+      (call-next-method))))
+
+(defun make-input-adapter (source)
+  (etypecase source
+    ;; If it's already a stream, we need to make sure it's not closed by the adapter
+    (stream
+     (assert (input-stream-p source))
+     (if (and (typep source 'adapter-flexi-input-stream)
+              (slot-value source 'ignore-close))
+         source ; already ignores CLOSE
+         (make-adapter-flexi-input-stream source :ignore-close t)))
+    ;; TODO(sterni): is this necessary? (maybe with (not *lazy-mime-decode*)?)
+    (string
+     (make-input-adapter (string-to-octets source)))
+    ((vector (unsigned-byte 8))
+     (make-in-memory-input-stream source))
+    (pathname
+     (make-flexi-stream (open source :element-type '(unsigned-byte 8))))
+    (file-portion
+     (open-decoded-file-portion source))))
+
+(defun make-adapter-flexi-input-stream (stream &rest args)
+  "Create a ADAPTER-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as
+MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. If T, the underlying stream is not
+closed."
+  (make-custom-flexi-stream 'adapter-flexi-input-stream stream args))
+
+(defclass positioned-flexi-input-stream (adapter-flexi-input-stream)
+  ()
+  (:documentation
+   "FLEXI-INPUT-STREAM that automatically advances the underlying :STREAM to
+the location given by :POSITION. This uses FILE-POSITION internally, so it'll
+only works if the underlying stream position is tracked in bytes. Note that
+the underlying stream is still advanced, so having multiple instances of
+POSITIONED-FLEXI-INPUT-STREAM based with the same underlying stream won't work
+reliably.
+Also supports :IGNORE-CLOSE of ADAPTER-FLEXI-INPUT-STREAM."))
+
+(defmethod initialize-instance ((stream positioned-flexi-input-stream)
+                                &key &allow-other-keys)
+  (call-next-method)
+  ;; The :POSITION initarg is only informational for flexi-streams: It assumes
+  ;; it is were the stream it got is already at and continuously updates it
+  ;; for querying (via FLEXI-STREAM-POSITION) and bound checking.
+  ;; Since we have streams that are not positioned correctly, we need to do this
+  ;; here using FILE-POSITION. Note that assumes the underlying implementation
+  ;; uses bytes for FILE-POSITION which is not guaranteed (probably some streams
+  ;; even in SBCL don't).
+  (file-position (flexi-stream-stream stream) (flexi-stream-position stream)))
+
+(defun make-positioned-flexi-input-stream (stream &rest args)
+  "Create a POSITIONED-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as
+MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. Causes the FILE-POSITION of STREAM to
+be modified to match the :POSITION argument."
+  (make-custom-flexi-stream 'positioned-flexi-input-stream stream args))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO(sterni): test correct behavior with END NIL
+(defstruct file-portion
+  data                                  ; string or a pathname
+  encoding
+  start
+  end)
+
+(defun open-decoded-file-portion (file-portion)
+  (with-slots (data encoding start end)
+      file-portion
+    (let* ((binary-stream
+             (etypecase data
+               (pathname
+                (open data :element-type '(unsigned-byte 8)))
+               ((vector (unsigned-byte 8))
+                (flexi-streams:make-in-memory-input-stream data))
+               (stream
+                ;; TODO(sterni): assert that bytes/flexi-stream
+                data)))
+           (params (ccase encoding
+                     ((:quoted-printable :base64) '(:external-format :us-ascii))
+                     (:8bit '(:element-type (unsigned-byte 8)))
+                     (:7bit '(:external-format :us-ascii))))
+           (portion-stream (apply #'make-positioned-flexi-input-stream
+                                  binary-stream
+                                  :position start
+                                  :bound end
+                                  ;; if data is a stream we can't have a
+                                  ;; FILE-PORTION without modifying it when
+                                  ;; reading etc. The least we can do, though,
+                                  ;; is forgo destroying it.
+                                  :ignore-close (typep data 'stream)
+                                  params))
+           (needs-decoder-stream (member encoding '(:quoted-printable
+                                                    :base64))))
+
+      (if needs-decoder-stream
+          (make-instance
+           (ccase encoding
+             (:quoted-printable 'quoted-printable-decoder-stream)
+             (:base64 'qbase64:decode-stream))
+           :underlying-stream portion-stream)
+          portion-stream))))