refactor(3p/lisp/mime4cl): port remaining base64 decoding to qbase64

DECODE-BASE64-STREAM-TO-SEQUENCE is the only thing that requires
anything fancy: We read into an adjustable array. Alternative could be
using REDIRECT-STREAM and WITH-OUTPUT-TO-STRING, but that is likely
slower (untested).

Test cases are kept for now to confirm that qbase64 is conforming to our
expectations, but can probably dropped in favor of a few more sample
messages in the test suite.

:START and :END are sadly no longer supported and need to be replaced by
SUBSEQ.

Change-Id: I5928aed7551b0dea32ee09518ea6f604b40c2863
Reviewed-on: https://cl.tvl.fyi/c/depot/+/8586
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Autosubmit: sterni <sternenseemann@systemli.org>
This commit is contained in:
sterni 2023-05-18 17:19:34 +02:00 committed by clbot
parent 02684f3ac6
commit b388354c4d
4 changed files with 39 additions and 75 deletions

View file

@ -22,19 +22,21 @@
(in-package :mime4cl) (in-package :mime4cl)
(defun redirect-stream (in out &key (buffer-size 4096))
"Consume input stream IN and write all its content to output stream OUT.
The streams' element types need to match."
(let ((buf (make-array buffer-size :element-type (stream-element-type in))))
(loop for pos = (read-sequence buf in)
while (> pos 0)
do (write-sequence buf out :end pos))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Thank you SBCL for rendering constants totally useless! ;; Thank you SBCL for rendering constants totally useless!
(defparameter +base64-encode-table+ (defparameter +base64-encode-table+
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")
(defparameter +base64-decode-table+ (declaim (type simple-string +base64-encode-table+))
(let ((da (make-array 256 :element-type '(unsigned-byte 8) :initial-element 65)))
(dotimes (i 64)
(setf (aref da (char-code (char +base64-encode-table+ i))) i))
da))
(declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+)
(type simple-string +base64-encode-table+))
(defvar *base64-line-length* 76 (defvar *base64-line-length* 76
"Maximum length of the encoded base64 line. NIL means it can "Maximum length of the encoded base64 line. NIL means it can
@ -484,60 +486,34 @@ return it."
(with-output-to-string (out) (with-output-to-string (out)
(encode-base64-sequence-to-stream sequence out :start start :end end))) (encode-base64-sequence-to-stream sequence out :start start :end end)))
(defclass base64-decoder (parsing-decoder)
((bitstore :initform 0
:type fixnum)
(bytecount :initform 0 :type fixnum))
(:documentation
"Class for Base64 decoder input streams."))
(defmethod decoder-read-byte ((decoder base64-decoder))
(declare (optimize (speed 3) (safety 0) (debug 0)))
(with-slots (bitstore bytecount input-function) decoder
(declare (type fixnum bitstore bytecount)
(type function input-function))
(labels ((in6 ()
(loop
for c = (funcall input-function)
when (or (not c) (char= #\= c))
do (return-from decoder-read-byte nil)
do (let ((sextet (aref +base64-decode-table+ (char-code c))))
(unless (= sextet 65) ; ignore unrecognised characters
(return sextet)))))
(push6 (sextet)
(declare (type fixnum sextet))
(setf bitstore
(logior sextet (the fixnum (ash bitstore 6))))))
(case bytecount
(0
(setf bitstore (in6))
(push6 (in6))
(setf bytecount 1)
(ash bitstore -4))
(1
(push6 (in6))
(setf bytecount 2)
(logand #xFF (ash bitstore -2)))
(2
(push6 (in6))
(setf bytecount 0)
(logand #xFF bitstore))))))
(defun decode-base64-stream (in out &key parser-errors) (defun decode-base64-stream (in out &key parser-errors)
"Read from IN a stream of characters Base64 encoded and write "Read from IN a stream of characters Base64 encoded and write
to OUT a stream of decoded bytes." to OUT a stream of decoded bytes."
(make-decoder-loop base64-decoder ;; parser-errors are ignored for base64
(read-byte in nil) (write-byte byte out) (declare (ignore parser-errors))
:parser-errors parser-errors)) (redirect-stream (make-instance 'qbase64:decode-stream
:underlying-stream in)
out))
(defun decode-base64-stream-to-sequence (stream &key parser-errors) (defun decode-base64-stream-to-sequence (stream &key parser-errors)
(make-stream-to-sequence-decoder base64-decoder "Read Base64 characters from STREAM and return result of decoding them as a
(read-char stream nil) binary sequence."
:parser-errors parser-errors)) ;; parser-errors are ignored for base64
(declare (ignore parser-errors))
(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors) (let* ((buffered-size 4096)
(with-input-from-string (in string :start start :end end) (dstream (make-instance 'qbase64:decode-stream
(decode-base64-stream-to-sequence in :parser-errors parser-errors))) :underlying-stream stream))
(output-seq (make-array buffered-size
:element-type '(unsigned-byte 8)
:adjustable t)))
(loop for cap = (array-dimension output-seq 0)
for pos = (read-sequence output-seq dstream :start (or pos 0))
if (>= pos cap)
do (adjust-array output-seq (+ cap buffered-size))
else
do (progn
(adjust-array output-seq pos)
(return output-seq)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -565,8 +541,8 @@ to OUT a stream of decoded bytes."
(decode-quoted-printable-string string (decode-quoted-printable-string string
:parser-errors parser-errors-p)) :parser-errors parser-errors-p))
(:base64 (:base64
(decode-base64-string string ;; parser-errors-p is unused in base64
:parser-errors parser-errors-p)) (qbase64:decode-string string))
(otherwise (otherwise
(map '(vector (unsigned-byte 8)) #'char-code string)))) (map '(vector (unsigned-byte 8)) #'char-code string))))
@ -650,7 +626,7 @@ method of RFC2047 and return a sequence of bytes."
bytes." bytes."
(gcase (encoding string-equal) (gcase (encoding string-equal)
("Q" (decode-quoted-printable-RFC2047-string string :start start :end end)) ("Q" (decode-quoted-printable-RFC2047-string string :start start :end end))
("B" (decode-base64-string string :start start :end end)) ("B" (qbase64:decode-string (subseq string start end)))
(t string))) (t string)))
(defun parse-RFC2047-text (text) (defun parse-RFC2047-text (text)

View file

@ -66,8 +66,6 @@
#:decode-quoted-printable-string #:decode-quoted-printable-string
#:encode-quoted-printable-stream #:encode-quoted-printable-stream
#:encode-quoted-printable-sequence #:encode-quoted-printable-sequence
#:decode-base64-stream
#:decode-base64-string
#:encode-base64-stream #:encode-base64-stream
#:encode-base64-sequence #:encode-base64-sequence
#:parse-RFC2047-text #:parse-RFC2047-text
@ -83,7 +81,6 @@
#:with-input-from-mime-body-stream #:with-input-from-mime-body-stream
;; endec.lisp ;; endec.lisp
#:base64-encoder #:base64-encoder
#:base64-decoder
#:null-encoder #:null-encoder
#:null-decoder #:null-decoder
#:byte-encoder #:byte-encoder

View file

@ -27,14 +27,6 @@
(flexi-stream-root-stream (flexi-stream-stream stream)) (flexi-stream-root-stream (flexi-stream-stream stream))
stream)) stream))
(defun redirect-stream (in out &key (buffer-size 4096))
"Consume input stream IN and write all its content to output stream OUT.
The streams' element types need to match."
(let ((buf (make-array buffer-size :element-type (stream-element-type in))))
(loop for pos = (read-sequence buf in)
while (> pos 0)
do (write-sequence buf out :end pos))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass coder-stream-mixin () (defclass coder-stream-mixin ()

View file

@ -103,13 +103,12 @@ line")
(deftest base64.3 (deftest base64.3
(map 'string #'code-char (map 'string #'code-char
(decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg==")) (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg=="))
"Some random string.") "Some random string.")
(deftest base64.4 (deftest base64.4
(map 'string #'code-char (map 'string #'code-char
(decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish" (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg=="))
:start 13 :end 41))
"Some random string.") "Some random string.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -117,6 +116,7 @@ line")
(deftest RFC2047.1 (deftest RFC2047.1
(parse-RFC2047-text "foo bar") (parse-RFC2047-text "foo bar")
("foo bar")) ("foo bar"))
;; TODO(sterni): more RFC2047 test cases
(defun perftest-encoder (encoder-class &optional (megs 100)) (defun perftest-encoder (encoder-class &optional (megs 100))
(declare (optimize (speed 3) (debug 0) (safety 0)) (declare (optimize (speed 3) (debug 0) (safety 0))
@ -145,7 +145,6 @@ line")
(let* ((meg (* 1024 1024)) (let* ((meg (* 1024 1024))
(buffer (make-sequence '(vector (unsigned-byte 8)) meg)) (buffer (make-sequence '(vector (unsigned-byte 8)) meg))
(encoder-class (ecase decoder-class (encoder-class (ecase decoder-class
(mime4cl:base64-decoder 'mime4cl:base64-encoder)
(mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder))) (mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder)))
(encoder (make-instance encoder-class (encoder (make-instance encoder-class
:output-function #'(lambda (c) :output-function #'(lambda (c)