diff options
Diffstat (limited to 'src/base32.lisp')
| -rw-r--r-- | src/base32.lisp | 191 |
1 files changed, 191 insertions, 0 deletions
diff --git a/src/base32.lisp b/src/base32.lisp new file mode 100644 index 0000000..0ed4624 --- /dev/null +++ b/src/base32.lisp @@ -0,0 +1,191 @@ +;; Copyright (c) 2011 Phil Hargett + +;; Permission is hereby granted, free of charge, to any person obtaining a copy +;; of this software and associated documentation files (the "Software"), to deal +;; in the Software without restriction, including without limitation the rights +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;; copies of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +;; THE SOFTWARE. + +;; +;; Base32 encoding - http://tools.ietf.org/html/rfc4648 +;; + +;; Adapted for eris-cl + +(in-package :eris) +(define-constant +base32-alphabet+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" :test #'equalp) + +(defun encode-word (a-word) + "Return the digit in the base32 alphabet corresponding to a word" + (char +base32-alphabet+ a-word)) + +(defun decode-word (a-digit) + "Return the word encoded as a digit in the base32 alphabet" + (let ((code (char-code a-digit))) + (or (and (char<= #\a a-digit #\z) + (- code (char-code #\a))) + (and (char<= #\2 a-digit #\7) + (+ 26 (- code (char-code #\2)))) + ;; upper case + (and (char<= #\A a-digit #\Z) + (- code (char-code #\A)))))) + +(defun read-word (some-bytes word-index) + "Return the word (a 5-bit integer) found in some-bytes located at word-index" + (let* ((bytes-length (length some-bytes)) + ;; don't be confused : bit indexes aren't really pointing to + ;; the bit as understood by Lisp--they are more virtual in nature, + ;; which assumes that bit 0 is the MSB rather than bit 8 being MSB + (start-bit-index (* 5 word-index) ) + (end-bit-index (+ 4 start-bit-index) ) + (part1-byte-index (floor start-bit-index 8)) + (part2-byte-index (floor end-bit-index 8)) + (part1-size (min 5 (- 8 (mod start-bit-index 8)))) + (part2-size (- 5 part1-size)) + ;; here we translate the bit indexes so that the MSB is bit 8 + ;; and the LSB is bit 0 + (source-part1 (byte part1-size + (- (- 8 (mod start-bit-index 8)) part1-size) + ) + ) + (source-part2 (byte part2-size + (- (- 8 (mod end-bit-index 8)) 1) ) + ) + ;; becomes the upper bits in value + (dest-part1 (byte part1-size part2-size)) + ;; becomes the lower bits in value + (dest-part2 (byte part2-size 0)) + (value 0)) + + (setf (ldb dest-part1 value) + (ldb source-part1 (aref some-bytes part1-byte-index))) + (if (< part1-byte-index bytes-length) + (if (> part2-byte-index part1-byte-index) + (if (< part2-byte-index (length some-bytes)) + (setf (ldb dest-part2 value) + (ldb source-part2 (aref some-bytes part2-byte-index))) + (setf (ldb dest-part2 value) 0 ))) + (setq value 0)) + value)) + +(defun write-word (some-bytes word-index word) + "Write the word into the bits located at word-index in some-bytes" + (let* ( + (bytes-length (length some-bytes)) + ;; don't be confused : bit indexes aren't really pointing to + ;; the bit as understood by Lisp--they are more virtual in nature, + ;; which assumes that bit 0 is the MSB rather than bit 8 being MSB + (start-bit-index (* 5 word-index) ) + (end-bit-index (+ 4 start-bit-index) ) + (part1-byte-index (floor start-bit-index 8)) + (part2-byte-index (floor end-bit-index 8)) + (part1-size (min 5 (- 8 (mod start-bit-index 8)))) + (part2-size (- 5 part1-size)) + ;; here we translate the bit indexes so that the MSB is bit 8 + ;; and the LSB is bit 0 + (dest-part1 (byte part1-size + (- (- 8 (mod start-bit-index 8)) part1-size))) + (dest-part2 (byte part2-size + (- (- 8 (mod end-bit-index 8)) 1) )) + ;; becomes the upper bits in value + (source-part1 (byte part1-size part2-size)) + ;; becomes the lower bits in value + (source-part2 (byte part2-size 0)) + (part1-byte (aref some-bytes part1-byte-index)) + (part2-byte (if (and (< part2-byte-index bytes-length) + (> part2-size 0)) + (aref some-bytes part2-byte-index)))) + (setf (ldb dest-part1 part1-byte) + (ldb source-part1 word)) + (if part2-byte + (setf (ldb dest-part2 part2-byte) + (ldb source-part2 word))) + (setf (aref some-bytes part1-byte-index) part1-byte) + (if part2-byte + (setf (aref some-bytes part2-byte-index) part2-byte)))) + +(defun unpadded-base32-length (base32-string) + "Given a base32 string, compute the size of the raw base32 string, + without any = padding + " + (let* ((padded-length (length base32-string)) + (unpadded-length padded-length)) + (dotimes (i padded-length) + (if (eql #\= (aref base32-string (- padded-length i))) + (decf unpadded-length) + (return unpadded-length))))) + +(defun byte-length-from-base32 (base32-string) + "Given a base32 string, compute the number of bytes in the + decoded data + " + (let* ((padded-length (length base32-string)) + (unpadded-length padded-length) + (padding 0) + (block-count (ceiling padded-length 8))) + (if (<= padded-length 0) + 0 + (progn + (dotimes (i padded-length) + (if (eql #\= (aref base32-string (- padded-length i 1))) + (progn + (decf unpadded-length) + (incf padding)))) + (- (* 5 block-count) + (ecase padding + (0 0) + (6 4) + (4 3) + (3 2) + (1 1))))))) + +(defun base32-length-from-bytes (some-bytes) + "Given bytes of unencoded data, determine the length of the + corresponding base32-encoded string + " + (let* ((word-count (ceiling (* 8 (length some-bytes)) 5) ) + (digit-count (* 8 (ceiling word-count 8)))) + (values digit-count word-count))) + +(defun bytes-to-base32 (some-bytes) + "Return a base32 string encoding of the provided vector of bytes" + (let* ((word-count (ceiling (* 8 (length some-bytes)) 5) ) + (digit-count (* 8 (ceiling word-count 8))) + (base32-string (make-string digit-count :initial-element #\=))) + (dotimes (i word-count) + (setf (aref base32-string i) + (encode-word (read-word some-bytes i)))) + base32-string)) + +(defun base32-to-bytes (base32-string) + "Return the bytes decoded from the supplied base32 string" + (let* ((byte-count (byte-length-from-base32 base32-string) ) + (base32-bytes (make-array `(,byte-count) + :element-type '(unsigned-byte 8) + :initial-element 0))) + (dotimes (i (length base32-string)) + (let ((word (decode-word (aref base32-string i)))) + (if word + (write-word base32-bytes i word) + (return nil)))) + base32-bytes)) + +(defun base32-to-bytes-unpadded (base32-string) + (let ((padding (make-array (- 8 (mod (length base32-string) 8)) :element-type 'character :initial-element #\=))) + (base32-to-bytes (concatenate 'string base32-string padding)))) + +(defun bytes-to-base32-unpadded (bytes) + (let ((string (bytes-to-base32 bytes))) + (subseq string 0 (position #\= string)))) |