core:lisp/lib/dat/base64.lisp

changelog shortlog graph tags branches changeset files revisions annotate raw help
Mercurial > core / lisp/lib/dat/base64.lisp

changeset 698:	96958d3eb5b0
parent:	0e00dec3de03
author:	Richard Westhaver <ellis@rwest.io>
date:	Fri, 04 Oct 2024 22:04:59 -0400
permissions:	-rw-r--r--
description:	fixes
     1 ;;; dat/base64.lisp --- Base64 Strings
     2 
     3 ;; RFC 4648
     4 
     5 ;; see http://git.kpe.io/?p=cl-base64.git;a=summary
     6 
     7 ;; Copyright (c) 2002-2003 by Kevin Rosenberg
     8 
     9 ;;; Code:
    10 (in-package :dat/base64)
    11 
    12 ;;; encode
    13 (eval-when (:compile-toplevel :load-toplevel :execute)
    14   (defvar *encode-table*
    15     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
    16   (declaim (type simple-string *encode-table*))
    17 
    18   (defvar *uri-encode-table*
    19     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
    20   (declaim (type simple-string *uri-encode-table*))
    21 
    22   (defvar *pad-char* #\=)
    23   (defvar *uri-pad-char* #\.)
    24   (declaim (type character *pad-char* *uri-pad-char*))
    25 
    26   (deftype decode-table () '(simple-array (signed-byte 8) (128)))
    27   (defun make-decode-table (encode-table pad-char
    28                             &key (whitespace-chars
    29                                   '(#\Linefeed #\Return #\Space #\Tab)))
    30     (assert (< (length encode-table) 128)
    31             (encode-table)
    32             "Encode table too big: ~S" encode-table)
    33     (let ((dt (make-array 128 :element-type '(signed-byte 8)
    34                               :initial-element -1)))
    35       (declare (type decode-table dt))
    36       (loop for char across encode-table
    37             for index upfrom 0
    38             do (setf (aref dt (char-code char)) index))
    39       (setf (aref dt (char-code pad-char)) -2)
    40       (loop for char in whitespace-chars
    41             do (setf (aref dt (char-code char)) -3))
    42       dt)))
    43 
    44 (defconstant +decode-table+
    45   (if (boundp '+decode-table+)
    46       (symbol-value '+decode-table+)
    47       (make-decode-table *encode-table* *pad-char*)))
    48 (declaim (type decode-table +decode-table+))
    49 
    50 (defconstant +uri-decode-table+
    51   (if (boundp '+uri-decode-table+)
    52       (symbol-value '+uri-decode-table+)
    53       (make-decode-table *uri-encode-table* *uri-pad-char*)))
    54 (declaim (type decode-table +uri-decode-table+))
    55 
    56 (defun round-next-multiple (x n)
    57   "Round x up to the next highest multiple of n."
    58   (declare (fixnum n)
    59            (optimize (speed 3) (safety 1) (space 0)))
    60   (let ((remainder (mod x n)))
    61     (declare (fixnum remainder))
    62     (if (zerop remainder)
    63         x
    64         (the fixnum (+ x (the fixnum (- n remainder)))))))
    65 
    66 (defmacro def-*-to-base64-* (input-type output-type)
    67   `(defun ,(intern (concatenate 'string (symbol-name input-type)
    68                                 (symbol-name :-to-base64-)
    69                                 (symbol-name output-type)))
    70        (input
    71         ,@(when (eq output-type :stream)
    72             '(output))
    73         &key (uri nil) (columns 0))
    74      "Encode a string array to base64. If columns is > 0, designates
    75 maximum number of columns in a line and the string will be terminated
    76 with a #\Newline."
    77      (declare ,@(case input-type
    78                   (:string
    79                    '((string input)))
    80                   (:usb8-array
    81                    '((type (array (unsigned-byte 8) (*)) input))))
    82               (fixnum columns)
    83               (optimize (speed 3) (safety 1) (space 0)))
    84      (let ((pad (if uri *uri-pad-char* *pad-char*))
    85            (encode-table (if uri *uri-encode-table* *encode-table*)))
    86        (declare (simple-string encode-table)
    87                 (character pad))
    88        (let* ((string-length (length input))
    89               (complete-group-count (truncate string-length 3))
    90               (remainder (nth-value 1 (truncate string-length 3)))
    91               (padded-length (* 4 (truncate (+ string-length 2) 3)))
    92               ,@(when (eq output-type :string)
    93                   '((num-lines (if (plusp columns)
    94                                    (truncate (+ padded-length (1- columns)) columns)
    95                                    0))
    96                     (num-breaks (if (plusp num-lines)
    97                                     (1- num-lines)
    98                                     0))
    99                     (strlen (+ padded-length num-breaks))
   100                     (result (make-string strlen))
   101                     (ioutput 0)))
   102               (col (if (plusp columns)
   103                        0
   104                        (the fixnum (1+ padded-length)))))
   105          (declare (fixnum string-length padded-length col
   106                           ,@(when (eq output-type :string)
   107                               '(ioutput)))
   108                   ,@(when (eq output-type :string)
   109                       '((simple-string result))))
   110          (labels ((output-char (ch)
   111                     (if (= col columns)
   112                         (progn
   113                           ,@(case output-type
   114                               (:stream
   115                                '((write-char #\Newline output)))
   116                               (:string
   117                                '((setf (schar result ioutput) #\Newline)
   118                                  (incf ioutput))))
   119                           (setq col 1))
   120                         (incf col))
   121                     ,@(case output-type
   122                         (:stream
   123                          '((write-char ch output)))
   124                         (:string
   125                          '((setf (schar result ioutput) ch)
   126                            (incf ioutput)))))
   127                   (output-group (svalue chars)
   128                     (declare (fixnum svalue chars))
   129                     (output-char
   130                      (schar encode-table
   131                             (the fixnum
   132                                  (logand #x3f
   133                                          (the fixnum (ash svalue -18))))))
   134                     (output-char
   135                      (schar encode-table
   136                             (the fixnum
   137                                  (logand #x3f
   138                                          (the fixnum (ash svalue -12))))))
   139                     (if (> chars 2)
   140                         (output-char
   141                          (schar encode-table
   142                                 (the fixnum
   143                                      (logand #x3f
   144                                              (the fixnum (ash svalue -6))))))
   145                         (output-char pad))
   146                     (if (> chars 3)
   147                         (output-char
   148                          (schar encode-table
   149                                 (the fixnum
   150                                      (logand #x3f svalue))))
   151                         (output-char pad))))
   152            (do ((igroup 0 (the fixnum (1+ igroup)))
   153                 (isource 0 (the fixnum (+ isource 3))))
   154                ((= igroup complete-group-count)
   155                 (cond
   156                   ((= remainder 2)
   157                    (output-group
   158                     (the fixnum
   159                          (+
   160                           (the fixnum
   161                                (ash
   162                                 ,(case input-type
   163                                    (:string
   164                                     '(char-code (the character (char input isource))))
   165                                    (:usb8-array
   166                                     '(the fixnum (aref input isource))))
   167                                 16))
   168                           (the fixnum
   169                                (ash
   170                                 ,(case input-type
   171                                    (:string
   172                                     '(char-code (the character (char input
   173                                                                 (the fixnum (1+ isource))))))
   174                                    (:usb8-array
   175                                     '(the fixnum (aref input (the fixnum
   176                                                               (1+ isource))))))
   177                                 8))))
   178                     3))
   179                   ((= remainder 1)
   180                    (output-group
   181                     (the fixnum
   182                          (ash
   183                           ,(case input-type
   184                              (:string
   185                               '(char-code (the character (char input isource))))
   186                              (:usb8-array
   187                               '(the fixnum (aref input isource))))
   188                           16))
   189                     2)))
   190                 ,(case output-type
   191                    (:string
   192                     'result)
   193                    (:stream
   194                     'output)))
   195              (declare (fixnum igroup isource))
   196              (output-group
   197               (the fixnum
   198                    (+
   199                     (the fixnum
   200                          (ash
   201                           (the fixnum
   202                                ,(case input-type
   203                                   (:string
   204                                    '(char-code (the character (char input isource))))
   205                                   (:usb8-array
   206                                    '(aref input isource))))
   207                           16))
   208                     (the fixnum
   209                          (ash
   210                           (the fixnum
   211                                ,(case input-type
   212                                   (:string
   213                                    '(char-code (the character (char input
   214                                                                (the fixnum (1+ isource))))))
   215                                   (:usb8-array
   216                                    '(aref input (1+ isource)))))
   217                           8))
   218                     (the fixnum
   219                          ,(case input-type
   220                             (:string
   221                              '(char-code (the character (char input
   222                                                          (the fixnum (+ 2 isource))))))
   223                             (:usb8-array
   224                              '(aref input (+ 2 isource))))
   225                          )))
   226               4)))))))
   227 
   228 (def-*-to-base64-* :string :string)
   229 (def-*-to-base64-* :string :stream)
   230 (def-*-to-base64-* :usb8-array :string)
   231 (def-*-to-base64-* :usb8-array :stream)
   232 
   233 
   234 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
   235   "Encode an integer to base64 format."
   236   (declare (integer input)
   237            (fixnum columns)
   238            (optimize (speed 3) (space 0) (safety 1)))
   239   (let ((pad (if uri *uri-pad-char* *pad-char*))
   240         (encode-table (if uri *uri-encode-table* *encode-table*)))
   241     (declare (simple-string encode-table)
   242              (character pad))
   243     (let* ((input-bits (integer-length input))
   244            (byte-bits (round-next-multiple input-bits 8))
   245            (padded-bits (round-next-multiple byte-bits 6))
   246            (remainder-padding (mod padded-bits 24))
   247            (padding-bits (if (zerop remainder-padding)
   248                              0
   249                              (- 24 remainder-padding)))
   250            (padding-chars (/ padding-bits 6))
   251            (padded-length (/ (+ padded-bits padding-bits) 6))
   252            (last-line-len (if (plusp columns)
   253                               (- padded-length (* columns
   254                                                   (truncate
   255                                                    padded-length columns)))
   256                               0))
   257            (num-lines (if (plusp columns)
   258                           (truncate (+ padded-length (1- columns)) columns)
   259                           0))
   260            (num-breaks (if (plusp num-lines)
   261                            (1- num-lines)
   262                            0))
   263            (strlen (+ padded-length num-breaks))
   264            (last-char (1- strlen))
   265            (str (make-string strlen))
   266            (col (if (zerop last-line-len)
   267                     columns
   268                     last-line-len)))
   269       (declare (fixnum padded-length num-lines col last-char
   270                        padding-chars last-line-len))
   271       (unless (plusp columns)
   272         (setq col -1)) ;; set to flag to optimize in loop
   273 
   274       (dotimes (i padding-chars)
   275         (declare (fixnum i))
   276         (setf (schar str (the fixnum (- last-char i))) pad))
   277 
   278       (do* ((strpos (- last-char padding-chars) (1- strpos))
   279             (int (ash input (/ padding-bits 3))))
   280            ((minusp strpos)
   281             str)
   282         (declare (fixnum strpos) (integer int))
   283         (cond
   284           ((zerop col)
   285            (setf (schar str strpos) #\Newline)
   286            (setq col columns))
   287           (t
   288            (setf (schar str strpos)
   289                  (schar encode-table (the fixnum (logand int #x3f))))
   290            (setq int (ash int -6))
   291            (decf col)))))))
   292 
   293 (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
   294   "Encode an integer to base64 format."
   295   (declare (integer input)
   296            (fixnum columns)
   297            (optimize (speed 3) (space 0) (safety 1)))
   298   (let ((pad (if uri *uri-pad-char* *pad-char*))
   299         (encode-table (if uri *uri-encode-table* *encode-table*)))
   300     (declare (simple-string encode-table)
   301              (character pad))
   302     (let* ((input-bits (integer-length input))
   303            (byte-bits (round-next-multiple input-bits 8))
   304            (padded-bits (round-next-multiple byte-bits 6))
   305            (remainder-padding (mod padded-bits 24))
   306            (padding-bits (if (zerop remainder-padding)
   307                              0
   308                              (- 24 remainder-padding)))
   309            (padding-chars (/ padding-bits 6))
   310            (padded-length (/ (+ padded-bits padding-bits) 6))
   311            (strlen padded-length)
   312            (nonpad-chars (- strlen padding-chars))
   313            (last-nonpad-char (1- nonpad-chars))
   314            (str (make-string strlen)))
   315       (declare (fixnum padded-length last-nonpad-char))
   316       (do* ((strpos 0 (the fixnum (1+ strpos)))
   317             (int (ash input (/ padding-bits 3)) (ash int -6))
   318             (6bit-value (the fixnum (logand int #x3f))
   319                         (the fixnum (logand int #x3f))))
   320            ((= strpos nonpad-chars)
   321             (let ((col 0))
   322               (declare (fixnum col))
   323               (dotimes (i nonpad-chars)
   324                 (declare (fixnum i))
   325                 (write-char (schar str i) stream)
   326                 (when (plusp columns)
   327                   (incf col)
   328                   (when (= col columns)
   329                     (write-char #\Newline stream)
   330                     (setq col 0))))
   331               (dotimes (ipad padding-chars)
   332                 (declare (fixnum ipad))
   333                 (write-char pad stream)
   334                 (when (plusp columns)
   335                   (incf col)
   336                   (when (= col columns)
   337                     (write-char #\Newline stream)
   338                     (setq col 0)))))
   339             stream)
   340         (declare (fixnum 6bit-value strpos)
   341                  (integer int))
   342         (setf (schar str (- last-nonpad-char strpos))
   343               (schar encode-table 6bit-value))
   344         ))))
   345 
   346 (define-condition base64-error (error)
   347   ((input
   348     :initarg :input
   349     :reader base64-error-input)
   350    (position
   351     :initarg :position
   352     :reader base64-error-position
   353     :type unsigned-byte)))
   354 
   355 (define-condition bad-base64-character (base64-error)
   356   ((code :initarg :code :reader bad-base64-character-code))
   357   (:report (lambda (condition stream)
   358              (format stream "Bad character ~S at index ~D of ~S"
   359                      (code-char (bad-base64-character-code condition))
   360                      (base64-error-position condition)
   361                      (base64-error-input condition)))))
   362 
   363 (define-condition incomplete-base64-data (base64-error)
   364   ()
   365   (:report (lambda (condition stream)
   366              (format stream "Unexpected end of Base64 data at index ~D of ~S"
   367                      (base64-error-position condition)
   368                      (base64-error-input condition)))))
   369 
   370 (deftype array-index (&optional (length array-dimension-limit))
   371   `(integer 0 (,length)))
   372 
   373 (deftype array-length (&optional (length array-dimension-limit))
   374   `(integer 0 ,length))
   375 
   376 (deftype character-code ()
   377   `(integer 0 (,char-code-limit)))
   378 
   379 (defmacro etypecase/unroll ((var &rest types) &body body)
   380   #+sbcl `(etypecase ,var
   381             ,@(loop for type in types
   382                     collect `(,type ,@body)))
   383   #-sbcl `(locally
   384               (declare (type (or ,@types) ,var))
   385             ,@body))
   386 
   387 (defmacro let/typed ((&rest vars) &body body)
   388   `(let ,(loop for (var value) in vars
   389                collect (list var value))
   390      (declare ,@(loop for (var nil type) in vars
   391                       when type
   392                       collect (list 'type type var)))
   393      ,@body))
   394 
   395 (defmacro define-base64-decoder (hose sink)
   396   `(defun ,(intern (format nil "~A-~A-~A-~A" '#:base64 hose '#:to sink))
   397        (input &key (table +decode-table+)
   398                    (uri nil)
   399                    ,@(when (eq sink :stream) `(stream))
   400                    (whitespace :ignore))
   401      ,(format nil "~
   402 Decode Base64 ~(~A~) to ~(~A~).
   403 
   404 TABLE is the decode table to use.  Two decode tables are provided:
   405 +DECODE-TABLE+ (used by default) and +URI-DECODE-TABLE+.  See
   406 MAKE-DECODE-TABLE.
   407 
   408 For backwards-compatibility the URI parameter is supported.  If it is
   409 true, then +URI-DECODE-TABLE+ is used, and the value for TABLE
   410 parameter is ignored.
   411 
   412 WHITESPACE can be one of:
   413 
   414   :ignore - Whitespace characters are ignored (default).
   415   :signal - Signal a BAD-BASE64-CHARACTER condition using SIGNAL.
   416   :error  - Signal a BAD-BASE64-CHARACTER condition using ERROR."
   417               hose sink)
   418      (declare (optimize (speed 3) (safety 1))
   419               (type decode-table table)
   420               (type ,(ecase hose
   421                        (:stream 'stream)
   422                        (:string 'string))
   423                     input))
   424      (let/typed ((decode-table (if uri +uri-decode-table+ table)
   425                                decode-table)
   426                  ,@(ecase sink
   427                      (:stream)
   428                      (:usb8-array
   429                       (ecase hose
   430                         (:stream
   431                          `((result (make-array 1024
   432                                                :element-type '(unsigned-byte 8)
   433                                                :adjustable t
   434                                                :fill-pointer 0)
   435                                    (array (unsigned-byte 8) (*)))))
   436                         (:string
   437                          `((result (make-array (* 3 (ceiling (length input) 4))
   438                                                :element-type '(unsigned-byte 8))
   439                                    (simple-array (unsigned-byte 8) (*)))
   440                            (rpos 0 array-index)))))
   441                      (:string
   442                       (case hose
   443                         (:stream
   444                          `((result (make-array 1024
   445                                                :element-type 'character
   446                                                :adjustable t
   447                                                :fill-pointer 0)
   448                                    (array character (*)))))
   449                         (:string
   450                          `((result (make-array (* 3 (ceiling (length input) 4))
   451                                                :element-type 'character)
   452                                    (simple-array character (*)))
   453                            (rpos 0 array-index)))))
   454                      (:integer
   455                       `((result 0 unsigned-byte)))))
   456        (flet ((bad-char (pos code &optional (action :error))
   457                 (let ((args (list 'bad-base64-character
   458                                   :input input
   459                                   :position pos
   460                                   :code code)))
   461                   (ecase action
   462                     (:error
   463                      (apply #'error args))
   464                     (:cerror
   465                      (apply #'cerror "Ignore the error and continue." args))
   466                     (:signal
   467                      (apply #'signal args)))))
   468               (incomplete-input (pos)
   469                 (error 'incomplete-base64-data :input input :position pos)))
   470          ,(let ((body
   471                   `(let/typed ((ipos 0 array-index)
   472                                (bitstore 0 (unsigned-byte 24))
   473                                (bitcount 0 (integer 0 14))
   474                                (svalue -1 (signed-byte 8))
   475                                (padchar 0 (integer 0 3))
   476                                (code 0 fixnum))
   477                      (loop
   478                           ,@(ecase hose
   479                               (:string
   480                                `((if (< ipos length)
   481                                      (setq code (char-code (aref input ipos)))
   482                                      (return))))
   483                               (:stream
   484                                `((let ((char (read-char input nil nil)))
   485                                    (if char
   486                                        (setq code (char-code char))
   487                                        (return))))))
   488                           (cond
   489                             ((or (< 127 code)
   490                                  (= -1 (setq svalue (aref decode-table code))))
   491                              (bad-char ipos code))
   492                             ((= -2 svalue)
   493                              (cond ((<= (incf padchar) 2)
   494                                     (unless (<= 2 bitcount)
   495                                       (bad-char ipos code))
   496                                     (decf bitcount 2))
   497                                    (t
   498                                     (bad-char ipos code))))
   499                             ((= -3 svalue)
   500                              (ecase whitespace
   501                                (:ignore
   502                                 ;; Do nothing.
   503                                 )
   504                                (:error
   505                                 (bad-char ipos code :error))
   506                                (:signal
   507                                 (bad-char ipos code :signal))))
   508                             ((not (zerop padchar))
   509                              (bad-char ipos code))
   510                             (t
   511                              (setf bitstore (logior (the (unsigned-byte 24)
   512                                                          (ash bitstore 6))
   513                                                     svalue))
   514                              (incf bitcount 6)
   515                              (when (>= bitcount 8)
   516                                (decf bitcount 8)
   517                                (let ((byte (logand (the (unsigned-byte 24)
   518                                                         (ash bitstore (- bitcount)))
   519                                                    #xFF)))
   520                                  (declare (type (unsigned-byte 8) byte))
   521                                  ,@(ecase sink
   522                                      (:usb8-array
   523                                       (ecase hose
   524                                         (:string
   525                                          `((setf (aref result rpos) byte)
   526                                            (incf rpos)))
   527                                         (:stream
   528                                          `((vector-push-extend byte result)))))
   529                                      (:string
   530                                       (ecase hose
   531                                         (:string
   532                                          `((setf (schar result rpos)
   533                                                  (code-char byte))
   534                                            (incf rpos)))
   535                                         (:stream
   536                                          `((vector-push-extend (code-char byte)
   537                                                                result)))))
   538                                      (:integer
   539                                       `((setq result
   540                                               (logior (ash result 8) byte))))
   541                                      (:stream
   542                                       '((write-char (code-char byte) stream)))))
   543                                (setf bitstore (logand bitstore #xFF)))))
   544                           (incf ipos))
   545                      (unless (zerop bitcount)
   546                        (incomplete-input ipos))
   547                      ,(ecase sink
   548                         ((:string :usb8-array)
   549                          (ecase hose
   550                            (:string
   551                             `(if (= rpos (length result))
   552                                  result
   553                                  (subseq result 0 rpos)))
   554                            (:stream
   555                             `(copy-seq result))))
   556                         (:integer
   557                          'result)
   558                         (:stream
   559                          'stream)))))
   560             (ecase hose
   561               (:string
   562                `(let ((length (length input)))
   563                   (declare (type array-length length))
   564                   (etypecase/unroll (input simple-base-string
   565                                            simple-string
   566                                            string)
   567                     ,body)))
   568               (:stream
   569                body)))))))
   570 
   571 (define-base64-decoder :string :usb8-array)
   572 (define-base64-decoder :string :string)
   573 (define-base64-decoder :string :integer)
   574 (define-base64-decoder :string :stream)
   575 
   576 (define-base64-decoder :stream :usb8-array)
   577 (define-base64-decoder :stream :string)
   578 (define-base64-decoder :stream :integer)
   579 (define-base64-decoder :stream :stream)
   580 
   581 ;; input-mode can be :string or :stream
   582 ;; input-format can be :character or :usb8