mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

96
third_party/lisp/mime4cl/endec.lisp vendored
View file

@ -22,19 +22,21 @@
(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!
(defparameter +base64-encode-table+
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")
(defparameter +base64-decode-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+))
(declaim (type simple-string +base64-encode-table+))
(defvar *base64-line-length* 76
"Maximum length of the encoded base64 line. NIL means it can
@ -484,60 +486,34 @@ return it."
(with-output-to-string (out)
(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)
"Read from IN a stream of characters Base64 encoded and write
to OUT a stream of decoded bytes."
(make-decoder-loop base64-decoder
(read-byte in nil) (write-byte byte out)
:parser-errors parser-errors))
;; parser-errors are ignored for base64
(declare (ignore parser-errors))
(redirect-stream (make-instance 'qbase64:decode-stream
:underlying-stream in)
out))
(defun decode-base64-stream-to-sequence (stream &key parser-errors)
(make-stream-to-sequence-decoder base64-decoder
(read-char stream nil)
:parser-errors parser-errors))
(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors)
(with-input-from-string (in string :start start :end end)
(decode-base64-stream-to-sequence in :parser-errors parser-errors)))
"Read Base64 characters from STREAM and return result of decoding them as a
binary sequence."
;; parser-errors are ignored for base64
(declare (ignore parser-errors))
(let* ((buffered-size 4096)
(dstream (make-instance 'qbase64:decode-stream
: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
:parser-errors parser-errors-p))
(:base64
(decode-base64-string string
:parser-errors parser-errors-p))
;; parser-errors-p is unused in base64
(qbase64:decode-string string))
(otherwise
(map '(vector (unsigned-byte 8)) #'char-code string))))
@ -650,7 +626,7 @@ method of RFC2047 and return a sequence of bytes."
bytes."
(gcase (encoding string-equal)
("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)))
(defun parse-RFC2047-text (text)

3
third_party/lisp/mime4cl/package.lisp vendored
View file

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

8
third_party/lisp/mime4cl/streams.lisp vendored
View file

@ -27,14 +27,6 @@
(flexi-stream-root-stream (flexi-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 ()

7
third_party/lisp/mime4cl/test/endec.lisp vendored
View file

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