decode.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          encode.lisp
   6 ;;;; Purpose:       cl-base64 encoding routines
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Dec 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file implements the Base64 transfer encoding algorithm as
  13 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
  14 ;;;; See: http://www.ietf.org/rfc/rfc1521.txt
  15 ;;;;
  16 ;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
  17 ;;;;
  18 ;;;; Copyright 2002-2003 Kevin M. Rosenberg
  19 ;;;; Permission to use with BSD-style license included in the COPYING file
  20 ;;;; *************************************************************************
  21
  22 (in-package #:cl-base64)
  23
  24 (define-condition base64-error (error)
  25   ((input
  26     :initarg :input
  27     :reader base64-error-input)
  28    (position
  29     :initarg :position
  30     :reader base64-error-position
  31     :type unsigned-byte)))
  32
  33 (define-condition bad-base64-character (base64-error)
  34   ((code :initarg :code :reader bad-base64-character-code))
  35   (:report (lambda (condition stream)
  36              (format stream "Bad character ~S at index ~D of ~S"
  37                      (code-char (bad-base64-character-code condition))
  38                      (base64-error-position condition)
  39                      (base64-error-input condition)))))
  40
  41 (define-condition incomplete-base64-data (base64-error)
  42   ()
  43   (:report (lambda (condition stream)
  44              (format stream "Unexpected end of Base64 data at index ~D of ~S"
  45                      (base64-error-position condition)
  46                      (base64-error-input condition)))))
  47
  48 (deftype array-index (&optional (length array-dimension-limit))
  49   `(integer 0 (,length)))
  50
  51 (deftype array-length (&optional (length array-dimension-limit))
  52   `(integer 0 ,length))
  53
  54 (deftype character-code ()
  55   `(integer 0 (,char-code-limit)))
  56
  57 (defmacro etypecase/unroll ((var &rest types) &body body)
  58   #+sbcl `(etypecase ,var
  59             ,@(loop for type in types
  60                     collect `(,type ,@body)))
  61   #-sbcl `(locally
  62               (declare (type (or ,@types) ,var))
  63             ,@body))
  64
  65 (defmacro let/typed ((&rest vars) &body body)
  66   `(let ,(loop for (var value) in vars
  67                collect (list var value))
  68      (declare ,@(loop for (var nil type) in vars
  69                       when type
  70                         collect (list 'type type var)))
  71      ,@body))
  72
  73 (defmacro define-base64-decoder (hose sink)
  74   `(defun ,(intern (format nil "~A-~A-~A-~A" '#:base64 hose '#:to sink))
  75        (input &key (table +decode-table+)
  76                    (uri nil)
  77                    ,@(when (eq sink :stream) `(stream))
  78                    (whitespace :ignore))
  79      ,(format nil "~
  80 Decode Base64 ~(~A~) to ~(~A~).
  81
  82 TABLE is the decode table to use.  Two decode tables are provided:
  83 +DECODE-TABLE+ (used by default) and +URI-DECODE-TABLE+.  See
  84 MAKE-DECODE-TABLE.
  85
  86 For backwards-compatibility the URI parameter is supported.  If it is
  87 true, then +URI-DECODE-TABLE+ is used, and the value for TABLE
  88 parameter is ignored.
  89
  90 WHITESPACE can be one of:
  91
  92   :ignore - Whitespace characters are ignored (default).
  93   :signal - Signal a BAD-BASE64-CHARACTER condition using SIGNAL.
  94   :error  - Signal a BAD-BASE64-CHARACTER condition using ERROR."
  95               hose sink)
  96      (declare (optimize (speed 3) (safety 1))
  97               (type decode-table table)
  98               (type ,(ecase hose
  99                        (:stream 'stream)
 100                        (:string 'string))
 101                     input))
 102      (let/typed ((decode-table (if uri +uri-decode-table+ table)
 103                                decode-table)
 104                  ,@(ecase sink
 105                      (:stream)
 106                      (:usb8-array
 107                       (ecase hose
 108                         (:stream
 109                          `((result (make-array 1024
 110                                  :element-type '(unsigned-byte 8)
 111                                                :adjustable t
 112                                                :fill-pointer 0)
 113                                    (array (unsigned-byte 8) (*)))))
 114                         (:string
 115                          `((result (make-array (* 3 (ceiling (length input) 4))
 116                                                :element-type '(unsigned-byte 8))
 117                                    (simple-array (unsigned-byte 8) (*)))
 118                            (rpos 0 array-index)))))
 119                           (:string
 120                       (case hose
 121                       (:stream
 122                          `((result (make-array 1024
 123                                                :element-type 'character
 124                                                :adjustable t
 125                                                :fill-pointer 0)
 126                                    (array character (*)))))
 127                         (:string
 128                          `((result (make-array (* 3 (ceiling (length input) 4))
 129                                                :element-type 'character)
 130                                    (simple-array character (*)))
 131                            (rpos 0 array-index)))))
 132                      (:integer
 133                       `((result 0 unsigned-byte)))))
 134        (flet ((bad-char (pos code &optional (action :error))
 135                 (let ((args (list 'bad-base64-character
 136                                   :input input
 137                                   :position pos
 138                                   :code code)))
 139                   (ecase action
 140                     (:error
 141                      (apply #'error args))
 142                     (:cerror
 143                      (apply #'cerror "Ignore the error and continue." args))
 144                     (:signal
 145                      (apply #'signal args)))))
 146               (incomplete-input (pos)
 147                 (error 'incomplete-base64-data :input input :position pos)))
 148          ,(let ((body
 149                   `(let/typed ((ipos 0 array-index)
 150                                (bitstore 0 (unsigned-byte 24))
 151                                (bitcount 0 (integer 0 14))
 152                                (svalue -1 (signed-byte 8))
 153                                (padchar 0 (integer 0 3))
 154                                (code 0 fixnum))
 155                      (loop
 156                        ,@(ecase hose
 157                            (:string
 158                             `((if (< ipos length)
 159                                   (setq code (char-code (aref input ipos)))
 160                                   (return))))
 161                            (:stream
 162                             `((let ((char (read-char input nil nil)))
 163                                 (if char
 164                                     (setq code (char-code char))
 165                                     (return))))))
 166              (cond
 167                            ((or (< 127 code)
 168                                 (= -1 (setq svalue (aref decode-table code))))
 169                             (bad-char ipos code))
 170                            ((= -2 svalue)
 171                             (cond ((<= (incf padchar) 2)
 172                                    (unless (<= 2 bitcount)
 173                                      (bad-char ipos code))
 174                                    (decf bitcount 2))
 175                                   (t
 176                                    (bad-char ipos code))))
 177                            ((= -3 svalue)
 178                             (ecase whitespace
 179                               (:ignore
 180                                ;; Do nothing.
 181                                )
 182                               (:error
 183                                (bad-char ipos code :error))
 184                               (:signal
 185                                (bad-char ipos code :signal))))
 186                            ((not (zerop padchar))
 187                             (bad-char ipos code))
 188                            (t
 189                             (setf bitstore (logior (the (unsigned-byte 24)
 190                                                         (ash bitstore 6))
 191                                 svalue))
 192                 (incf bitcount 6)
 193                 (when (>= bitcount 8)
 194                   (decf bitcount 8)
 195                               (let ((byte (logand (the (unsigned-byte 24)
 196                                                        (ash bitstore (- bitcount)))
 197                                                   #xFF)))
 198                                 (declare (type (unsigned-byte 8) byte))
 199                                 ,@(ecase sink
 200                            (:usb8-array
 201                                      (ecase hose
 202                                        (:string
 203                                         `((setf (aref result rpos) byte)
 204                                           (incf rpos)))
 205                            (:stream
 206                                         `((vector-push-extend byte result)))))
 207                      (:string
 208                                      (ecase hose
 209                           (:string
 210                                         `((setf (schar result rpos)
 211                                                 (code-char byte))
 212                                           (incf rpos)))
 213                                        (:stream
 214                                         `((vector-push-extend (code-char byte)
 215                                                               result)))))
 216                                     (:integer
 217                                      `((setq result
 218                                              (logior (ash result 8) byte))))
 219                                     (:stream
 220                                      '((write-char (code-char byte) stream)))))
 221                               (setf bitstore (logand bitstore #xFF)))))
 222                          (incf ipos))
 223                      (unless (zerop bitcount)
 224                        (incomplete-input ipos))
 225                      ,(ecase sink
 226                         ((:string :usb8-array)
 227                          (ecase hose
 228                             (:string
 229                             `(if (= rpos (length result))
 230                                  result
 231                                  (subseq result 0 rpos)))
 232                             (:stream
 233                             `(copy-seq result))))
 234                         (:integer
 235                          'result)
 236                         (:stream
 237                          'stream)))))
 238             (ecase hose
 239               (:string
 240                `(let ((length (length input)))
 241                   (declare (type array-length length))
 242                   (etypecase/unroll (input simple-base-string
 243                                            simple-string
 244                                            string)
 245                     ,body)))
 246               (:stream
 247                body)))))))
 248
 249 (define-base64-decoder :string :usb8-array)
 250 (define-base64-decoder :string :string)
 251 (define-base64-decoder :string :integer)
 252 (define-base64-decoder :string :stream)
 253
 254 (define-base64-decoder :stream :usb8-array)
 255 (define-base64-decoder :stream :string)
 256 (define-base64-decoder :stream :integer)
 257 (define-base64-decoder :stream :stream)
 258
 259 ;; input-mode can be :string or :stream
 260 ;; input-format can be :character or :usb8