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:
parent
02684f3ac6
commit
b388354c4d
4 changed files with 39 additions and 75 deletions
96
third_party/lisp/mime4cl/endec.lisp
vendored
96
third_party/lisp/mime4cl/endec.lisp
vendored
|
@ -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)
|
||||||
|
|
3
third_party/lisp/mime4cl/package.lisp
vendored
3
third_party/lisp/mime4cl/package.lisp
vendored
|
@ -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
|
||||||
|
|
8
third_party/lisp/mime4cl/streams.lisp
vendored
8
third_party/lisp/mime4cl/streams.lisp
vendored
|
@ -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 ()
|
||||||
|
|
7
third_party/lisp/mime4cl/test/endec.lisp
vendored
7
third_party/lisp/mime4cl/test/endec.lisp
vendored
|
@ -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)
|
||||||
|
|
Loading…
Reference in a new issue