;;; endec.lisp --- encoder/decoder functions
;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero
;;; Copyright (C) 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 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+/=")
(declaim (type simple-string +base64-encode-table+))
(defvar *base64-line-length* 76
"Maximum length of the encoded base64 line. NIL means it can
be of unlimited length \(no line breaks will be done by the
encoding function).")
(defvar *quoted-printable-line-length* 72
"Maximum length of the encoded quoted printable line. NIL
means it can be of unlimited length \(no line breaks will be done
by the encoding function).")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass decoder ()
((input-function :initarg :input-function
:reader decoder-input-function
:type function
:documentation
"Function is called repeatedly by the decoder methods to get the next character.
It should return a character os NIL (indicating EOF)."))
(:documentation
"Abstract base class for decoders."))
(defclass parsing-decoder (decoder)
((parser-errors :initform nil
:initarg :parser-errors
:reader decoder-parser-errors
:type boolean))
(:documentation
"Abstract base class for decoders that do parsing."))
(defclass encoder ()
((output-function :initarg :output-function
:reader encoder-output-function
:type function
:documentation
"Function is called repeatedly by the encoder methods to output a character.
It should expect a character as its only argument."))
(:documentation
"Abstract base class for encoders."))
(defclass line-encoder (encoder)
((column :initform 0
:type fixnum)
(line-length :initarg :line-length
:initform nil
:reader encoder-line-length
:type (or fixnum null)))
(:documentation
"Abstract base class for line encoders."))
(defclass 8bit-decoder (decoder)
()
(:documentation
"Class for decoders that do nothing."))
(defclass 8bit-encoder (encoder)
()
(:documentation
"Class for encoders that do nothing."))
(defclass 7bit-decoder (decoder)
()
(:documentation
"Class for decoders that do nothing."))
(defclass 7bit-encoder (encoder)
()
(:documentation
"Class for encoders that do nothing."))
(defclass byte-decoder (decoder)
()
(:documentation
"Class for decoders that turns chars to bytes."))
(defclass byte-encoder (encoder)
()
(:documentation
"Class for encoders that turns bytes to chars."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric encoder-write-byte (encoder byte))
(defgeneric encoder-finish-output (encoder))
(defgeneric decoder-read-byte (decoder))
(defmethod encoder-finish-output ((encoder encoder))
(values))
(defmethod encoder-write-byte ((encoder 8bit-encoder) byte)
(funcall (slot-value encoder 'output-function)
(code-char byte))
(values))
(defmethod decoder-read-byte ((decoder 8bit-decoder))
(awhen (funcall (slot-value decoder 'input-function))
(char-code it)))
(defmethod encoder-write-byte ((encoder 7bit-encoder) byte)
(funcall (slot-value encoder 'output-function)
(code-char (logand #x7F byte)))
(values))
(defmethod decoder-read-byte ((decoder 7bit-decoder))
(awhen (funcall (slot-value decoder 'input-function))
(logand #x7F (char-code it))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence)))
(declare (optimize (speed 3) (safety 0) (debug 0))
(type fixnum start end)
(type vector sequence))
(loop
for i fixnum from start below end
for byte = (decoder-read-byte decoder)
while byte
do (setf (aref sequence i) byte)
finally (return i)))
(defun decoder-read-line (decoder)
(with-output-to-string (str)
(loop
for byte = (decoder-read-byte decoder)
unless byte
do (return-from decoder-read-line nil)
do (let ((c (code-char byte)))
(cond ((char= c #\return)
;; skip the newline
(decoder-read-byte decoder)
(return nil))
((char= c #\newline)
;; the #\return was missing
(return nil))
(t (write-char c str)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declaim (inline parse-hex))
(defun parse-hex (c1 c2)
"Parse two characters as hexadecimal and return their combined
value."
(declare (optimize (speed 3) (safety 0) (debug 0))
(type character c1 c2))
(flet ((digit-value (char)
(or (position char "0123456789ABCDEF")
(return-from parse-hex nil))))
(+ (* 16 (digit-value c1))
(digit-value c2))))
(defclass quoted-printable-decoder (parsing-decoder)
((saved-bytes :initform (make-queue))))
(defmethod decoder-read-byte ((decoder quoted-printable-decoder))
(declare (optimize (speed 3) (safety 0) (debug 0)))
(with-slots (input-function saved-bytes parser-errors) decoder
(declare (type function input-function))
(labels ((saveb (b)
(queue-append saved-bytes b)
(values))
(save (c)
(saveb (char-code c)))
(push-next ()
(let ((c (funcall input-function)))
(declare (type (or null character) c))
(cond ((not c))
((or (char= c #\space)
(char= c #\tab))
(save c)
(push-next))
((char= c #\=)
(let ((c1 (funcall input-function)))
(cond ((not c1)
(save #\=))
((char= c1 #\return)
;; soft line break: skip the next
;; character which we assume to be a
;; newline (pity if it isn't)
(funcall input-function)
(push-next))
((char= c1 #\newline)
;; soft line break: the #\return is
;; missing, but we are tolerant
(push-next))
(t
;; hexadecimal sequence: get the 2nd digit
(let ((c2 (funcall input-function)))
(if c2
(aif (parse-hex c1 c2)
(saveb it)
(if parser-errors
(error "invalid hex sequence ~A~A" c1 c2)
(progn
(save #\=)
(save c1)
(save c2))))
(progn
(save c)
(save c1))))))))
(t
(save c))))))
(or (queue-pop saved-bytes)
(progn
(push-next)
(queue-pop saved-bytes))))))
(defmacro make-encoder-loop (encoder-class input-form output-form)
(with-gensyms (encoder byte)
`(loop
with ,encoder = (make-instance ',encoder-class
:output-function #'(lambda (char) ,output-form))
for ,byte = ,input-form
while ,byte
do (encoder-write-byte ,encoder ,byte)
finally (encoder-finish-output ,encoder))))
(defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors)
(with-gensyms (decoder)
`(loop
with ,decoder = (make-instance ',decoder-class
:input-function #'(lambda () ,input-form)
:parser-errors ,parser-errors)
for byte = (decoder-read-byte ,decoder)
while byte
do ,output-form)))
(defun decode-quoted-printable-stream (in out &key parser-errors)
"Read from stream IN a quoted printable text and write to
binary output OUT the decoded stream of bytes."
(make-decoder-loop quoted-printable-decoder
(read-byte in nil) (write-byte byte out)
:parser-errors parser-errors))
(defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors)
"Decode the character stream STREAM and return a sequence of bytes."
(with-gensyms (output-sequence)
`(let ((,output-sequence (make-array 0
:element-type '(unsigned-byte 8)
:fill-pointer 0
:adjustable t)))
(make-decoder-loop ,decoder-class ,input-form
(vector-push-extend byte ,output-sequence)
:parser-errors ,parser-errors)
,output-sequence)))
(defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors)
"Read from STREAM a quoted printable text and return a vector of
bytes."
(make-stream-to-sequence-decoder quoted-printable-decoder
(read-char stream nil)
:parser-errors parser-errors))
(defun decode-quoted-printable-string (string &key (start 0) (end (length string)) parser-errors)
"Decode STRING as quoted printable sequence of characters and
return a decoded sequence of bytes."
(with-input-from-string (in string :start start :end end)
(decode-quoted-printable-stream-to-sequence in :parser-errors parser-errors)))
(defclass quoted-printable-encoder (line-encoder)
((line-length :initform *quoted-printable-line-length*
:type (or fixnum null))
(pending-space :initform nil
:type boolean)))
(defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte)
(declare (optimize (speed 3) (safety 0) (debug 0))
(type (unsigned-byte 8) byte))
(with-slots (output-function column pending-space line-length) encoder
(declare (type function output-function)
(type fixnum column)
(type (or fixnum null) line-length)
(type boolean pending-space))
(labels ((out (c)
(funcall output-function c)
(values))
(outs (str)
(declare (type simple-string str))
(loop
for c across str
do (out c))
(values))
(out2hex (x)
(declare (type fixnum x))
(multiple-value-bind (a b) (truncate x 16)
(out (digit-char a 16))
(out (digit-char b 16)))))
(cond ((= byte #.(char-code #\newline))
(when pending-space
(outs "=20")
(setf pending-space nil))
(out #\newline)
(setf column 0))
((= byte #.(char-code #\space))
(if pending-space
(progn
(out #\space)
(f++ column))
(setf pending-space t)))
(t
(when pending-space
(out #\space)
(f++ column)
(setf pending-space nil))
(cond ((or (< byte 32)
(= byte #.(char-code #\=))
(> byte 126))
(out #\=)
(out2hex byte)
(f++ column 3))
(t
(out (code-char byte))
(f++ column)))))
(when (and line-length
(>= column line-length))
;; soft line break
(outs #.(coerce '(#\= #\newline) 'string))
(setf column 0)))))
(defmethod encoder-finish-output ((encoder quoted-printable-encoder))
(declare (optimize (speed 3) (safety 0) (debug 0)))
(with-slots (pending-space output-function) encoder
(declare (type boolean pending-space)
(type function output-function))
(when pending-space
(flet ((outs (s)
(declare (type simple-string s))
(loop
for c across s
do (funcall output-function c))))
(setf pending-space nil)
(outs "=20")))))
(defun encode-quoted-printable-stream (in out)
"Read from IN a stream of bytes and write to OUT a stream of
characters quoted printables encoded."
(make-encoder-loop quoted-printable-encoder
(read-byte in nil)
(write-char char out)))
(defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
"Encode the sequence of bytes SEQUENCE and write to STREAM a
quoted printable sequence of characters."
(let ((i start))
(make-encoder-loop quoted-printable-encoder
(when (< i end)
(prog1 (elt sequence i)
(f++ i)))
(write-char char stream))))
(defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence)))
"Encode the sequence of bytes SEQUENCE into a quoted printable
string and return it."
(with-output-to-string (out)
(encode-quoted-printable-sequence-to-stream sequence out :start start :end end)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass base64-encoder (line-encoder)
((line-length :initform *base64-line-length*)
(bitstore :initform 0
:type fixnum)
(bytecount :initform 0
:type fixnum))
(:documentation
"Class for Base64 encoder output streams."))
(eval-when (:load-toplevel :compile-toplevel)
(unless (> most-positive-fixnum (expt 2 (* 8 3)))))
(macrolet ((with-encoder (encoder &body forms)
`(with-slots (bitstore line-length column bytecount output-function) ,encoder
(declare (type fixnum column)
(type fixnum bitstore bytecount)
(type (or fixnum null) line-length)
(type function output-function))
(labels ((emitr (i b)
(declare (type fixnum i b))
(unless (zerop i)
(emitr (1- i) (ash b -6)))
(emitc
(char +base64-encode-table+ (logand b #x3F)))
(values))
(out (c)
(funcall output-function c))
(eol ()
(progn
(out #\return)
(out #\newline)))
(emitc (char)
(out char)
(f++ column)
(when (and line-length
(>= column line-length))
(setf column 0)
(eol))))
(declare (inline out eol emitc)
(ignorable (function emitr) (function out) (function eol) (function emitc)))
,@forms))))
;; For this function to work correctly, the FIXNUM must be at least
;; 24 bits.
(defmethod encoder-write-byte ((encoder base64-encoder) byte)
(declare (optimize (speed 3) (safety 0) (debug 0))
(type (unsigned-byte 8) byte))
(with-encoder encoder
(setf bitstore (logior byte (the fixnum (ash bitstore 8))))
(f++ bytecount)
(when (= 3 bytecount)
(emitr 3 bitstore)
(setf bitstore 0
bytecount 0)))
(values))
(defmethod encoder-finish-output ((encoder base64-encoder))
(with-encoder encoder
(unless (zerop bytecount)
(multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6)
(setf bitstore (ash bitstore (- 6 rest)))
(emitr saved6 bitstore)
(dotimes (x (- 3 saved6))
(emitc #\=))))
(when (and line-length
(not (zerop column)))
(eol)))
(values)))
(defun encode-base64-stream (in out)
"Read a byte stream from IN and write to OUT the encoded Base64
character stream."
(make-encoder-loop base64-encoder (read-byte in nil)
(write-char char out)))
(defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
"Encode the sequence of bytes SEQUENCE and write to STREAM the
Base64 character sequence."
(let ((i start))
(make-encoder-loop base64-encoder
(when (< i end)
(prog1 (elt sequence i)
(incf i)))
(write-char char stream))))
(defun encode-base64-sequence (sequence &key (start 0) (end (length sequence)))
"Encode the sequence of bytes SEQUENCE into a Base64 string and
return it."
(with-output-to-string (out)
(encode-base64-sequence-to-stream sequence out :start start :end end)))
(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."
;; 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)
"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)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun dump-stream-binary (in out)
"Write content of IN character stream to OUT binary stream."
(loop
for c = (read-char in nil)
while c
do (write-byte (char-code c) out)))
(defun decode-string (string encoding &key parser-errors-p)
(gcase (encoding string-equal)
(:quoted-printable
(decode-quoted-printable-string string
:parser-errors parser-errors-p))
(:base64
;; parser-errors-p is unused in base64
(qbase64:decode-string string))
(otherwise
(map '(vector (unsigned-byte 8)) #'char-code string))))
(defun decode-stream-to-sequence (stream encoding &key parser-errors-p)
(gcase (encoding string-equal)
(:quoted-printable
(decode-quoted-printable-stream-to-sequence stream
:parser-errors parser-errors-p))
(:base64
(decode-base64-stream-to-sequence stream
:parser-errors parser-errors-p))
(otherwise
(loop
with output-sequence = (make-array 0 :fill-pointer 0
:element-type '(unsigned-byte 8)
:adjustable t)
for c = (read-char stream nil)
while c
do (vector-push-extend (char-code c) output-sequence)
finally (return output-sequence)))))
(defun encode-stream (in out encoding)
(gcase (encoding string-equal)
(:quoted-printable
(encode-quoted-printable-stream in out))
(:base64
(encode-base64-stream in out))
(otherwise
(loop
for byte = (read-byte in nil)
while byte
do (write-char (code-char byte) out)))))
(defun encode-sequence-to-stream (sequence out encoding)
(gcase (encoding string-equal)
(:quoted-printable
(encode-quoted-printable-sequence-to-stream sequence out))
(:base64
(encode-base64-sequence-to-stream sequence out))
(otherwise
(loop
for byte across sequence
do (write-char (code-char byte) out)))))
(defun encode-sequence (sequence encoding)
(gcase (encoding string-equal)
(:quoted-printable
(encode-quoted-printable-sequence sequence))
(:base64
(encode-base64-sequence sequence))
(otherwise
(map 'string #'code-char sequence))))
;; This is similar to decode-quoted-printable-string but #\_ is used
;; instead of space
(defun decode-quoted-printable-RFC2047-string (string &key (start 0) (end (length string)))
"Decode a string encoded according to the quoted printable
method of RFC2047 and return a sequence of bytes."
(declare (optimize (speed 3) (debug 0) (safety 0))
(type simple-string string))
(loop
with output-sequence = (make-array (length string)
:element-type '(unsigned-byte 8)
:fill-pointer 0)
for i fixnum from start by 1 below end
for c = (char string i)
do (case c
(#\=
(vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i)))
;; the char code was malformed
#.(char-code #\?))
output-sequence)
(f++ i 2))
(#\_ (vector-push-extend #.(char-code #\space) output-sequence))
(otherwise
(vector-push-extend (char-code c) output-sequence)))
finally (return output-sequence)))
(defun decode-RFC2047-part (encoding string &key (start 0) (end (length string)))
"Decode STRING according to RFC2047 and return a sequence of
bytes."
(gcase (encoding string-equal)
("Q" (decode-quoted-printable-RFC2047-string string :start start :end end))
("B" (qbase64:decode-string (subseq string start end)))
(t string)))
(defun parse-RFC2047-text (text)
"Parse the string TEXT according to RFC2047 rules and return a list
of pairs and strings. The strings are the bits interposed between the
actually encoded text. The pairs are composed of: a decoded byte
sequence, a charset string indicating the original coding."
(loop
with result = '()
with previous-end = 0
for start = (search "=?" text :start2 previous-end)
while start
for first-? = (position #\? text :start (+ 2 start))
while first-?
for second-? = (position #\? text :start (1+ first-?))
while second-?
for end = (search "?=" text :start2 (1+ second-?))
while end
do (let ((charset (string-upcase (subseq text (+ 2 start) first-?)))
(encoding (subseq text (1+ first-?) second-?)))
(unless (= previous-end start)
(push (subseq text previous-end start)
result))
(setf previous-end (+ end 2))
(push (cons (decode-RFC2047-part encoding text :start (1+ second-?) :end end)
charset)
result))
finally (unless (= previous-end (length text))
(push (subseq text previous-end (length text))
result))
(return (nreverse result))))
(defun decode-RFC2047 (text)
"Decode TEXT into a fully decoded string. Whenever a non ASCII part is
encountered, try to decode it using babel, otherwise signal an error."
(flet ((decode-part (part)
(etypecase part
(cons (flexi-streams:octets-to-string
(car part)
:external-format (flexi-streams:make-external-format
(intern (string-upcase (cdr part)) 'keyword))))
(string part))))
(apply #'concatenate
(cons 'string
(mapcar #'decode-part (mime:parse-RFC2047-text text))))))
