diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/base32.lisp | 191 | ||||
| -rw-r--r-- | src/cache.lisp | 45 | ||||
| -rw-r--r-- | src/common.lisp | 10 | ||||
| -rw-r--r-- | src/conditions.lisp | 53 | ||||
| -rw-r--r-- | src/eris-decode.lisp | 291 | ||||
| -rw-r--r-- | src/eris.lisp | 244 | ||||
| -rw-r--r-- | src/package.lisp | 45 |
7 files changed, 879 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)))) diff --git a/src/cache.lisp b/src/cache.lisp new file mode 100644 index 0000000..ad6a0fa --- /dev/null +++ b/src/cache.lisp @@ -0,0 +1,45 @@ +;; This is a patch for function-cache, enabling a per-stream cache for +;; eris-decode-stream. + +(in-package :function-cache) + +(defmacro cached-lambda (cache-list lambda-list &body body) + "Creates a cached lambda function with the cache-list + cache-list is a list (&rest CACHE-INIT-ARGS + &key CACHE-CLASS TABLE TIMEOUT SHARED-RESULTS?) + + TABLE - a shared cache-store to use, usually a hash-table, a function that returns + a hashtable, or a symbol whose value is a hash-table + TIMEOUT - how long entries in the cache should be considered valid for + CACHE-CLASS - controls what cache class will be instantiated (uses + default-cache-class if not provided) + SHARED-RESULTS? - do we expect that we are sharing cache space with other things + defaults to t if TABLE is provided + CACHE-INIT-ARGS - any other args that should be passed to the cache + " + (destructuring-bind (&rest cache-args + &key table (shared-results? nil shared-result-input?) + cache-class + &allow-other-keys) + (ensure-list cache-list) + (declare (ignore cache-class)) ;; handled in default-cache-class + (remf cache-args :cache-class) + (remf cache-args :table) + (remf cache-args :shared-results?) + (when (and table (not shared-result-input?)) (setf shared-results? t)) + (let* ((cache-class (default-cache-class (cons nil cache-list) lambda-list)) + (call-list (%call-list-for-lambda-list lambda-list)) + (cache (gensym))) + `(let ((,cache + (make-instance ',cache-class + :body-fn (lambda ,lambda-list + ,@body) + :name nil + :lambda-list ',lambda-list + :shared-results? ,shared-results? + :cached-results ,table + ,@cache-args))) + (lambda ,lambda-list + (cacher ,cache ,call-list)))))) + +(export cached-lambda) diff --git a/src/common.lisp b/src/common.lisp new file mode 100644 index 0000000..3f078ff --- /dev/null +++ b/src/common.lisp @@ -0,0 +1,10 @@ +(in-package :eris) + +(defun subseq-shared (array start) + (make-array (- (length array) start) + :element-type (array-element-type array) + :displaced-to array + :displaced-index-offset start)) + +(defmacro make-octets (len &key (element 0)) + `(make-array ,len :element-type '(unsigned-byte 8) :initial-element ,element)) diff --git a/src/conditions.lisp b/src/conditions.lisp new file mode 100644 index 0000000..5b57fbf --- /dev/null +++ b/src/conditions.lisp @@ -0,0 +1,53 @@ +;; This file is part of eris-cl. +;; Copyright (C) 2022 Piotr Szarmański + +;; eris-cl 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 3 of the License, or (at your option) any +;; later versqion. + +;; eris-cl 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License along with +;; eris-cl. If not, see <https://www.gnu.org/licenses/>. + +(in-package :eris) + +(define-constant +eris-revision+ "0.3" :test #'equalp) + +(define-condition eris-condition () ()) + +(define-condition missing-block (eris-condition error) + ((reference :initarg :reference :reader reference)) + (:report (lambda (condition stream) + (format stream "Missing block: ~a" (reference condition))))) + +(define-condition padding-error (eris-condition error) + () + (:report "Corrupted padding.")) + +(define-condition version-mismatch (eris-condition error) + () + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream "Provided object has been encoded with a different version of the ERIS standard than ~a." +eris-revision+)))) + +(define-condition eof (eris-condition error) + ((eof :initarg :eof :reader eof) + (pos :initarg :position :reader pos)) + (:report (lambda (condition stream) + (with-slots (eof pos) condition + (format stream "End of file (~d) reached at ~d." eof pos))))) + +(define-condition hash-mismatch (eris-condition error) + ((reference :initarg :reference :reader reference) + (hash :initarg :hash :reader hash)) + (:report (lambda (condition stream) + (format stream "The hash ~a does not match the reference ~a." (hash condition) (reference condition))))) + +(define-condition invalid-internal-block (eris-condition error) + ((reference :initarg :reference :reader reference)) + (:report (lambda (condition stream) + (format stream "The internal block ~a is invalid." (reference condition))))) diff --git a/src/eris-decode.lisp b/src/eris-decode.lisp new file mode 100644 index 0000000..b7575ab --- /dev/null +++ b/src/eris-decode.lisp @@ -0,0 +1,291 @@ +;; This file is part of eris-cl. +;; Copyright (C) 2022 Piotr Szarmański + +;; eris-cl 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 3 of the License, or (at your option) any +;; later versqion. + +;; eris-cl 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License along with +;; eris-cl. If not, see <https://www.gnu.org/licenses/>. + +(in-package :eris) + +(defvar *decode-safety-checks* t + "If set to nil, disable computationally expensive safety checks that ensure the +fetched blocks are what they claim to be. Only disable this if the blocks are +fetched from a trusted party.") + +(defmacro hash-check (block hash) + `(when *decode-safety-checks* + (let ((hash (ironclad:digest-sequence :blake2/256 ,block))) + (unless (equalp ,hash hash) + (error 'hash-mismatch :reference ,hash :hash hash ))))) + +(defun key-reference-null? (kr) + (and (equalp (reference kr) null-secret) + (equalp (key kr) null-secret))) + +(defclass high-block () + ((data :initarg :data :accessor data :type (simple-array (unsigned-byte 8))) + (position :initarg :position :accessor pos :type integer + :documentation "Position relative to the higher block.") + (level :initarg :level :accessor level :type (unsigned-byte 8)))) + +(defclass buffer () + ((data :initarg :data :accessor data :type (simple-array (unsigned-byte 8))) + (pos :initarg :pos :accessor pos :type fixnum) + (eof :initarg :eof :accessor eof :type fixnum + :documentation "Either the position of the EOF in the buffer, or the length of the buffer."))) + +(defclass eris-decode-stream (fundamental-binary-input-stream) + ((position :initform 0 :accessor pos :initarg :position :type integer) + (get-block :accessor get-block :initarg :get-block :type function) + (block-size :accessor block-size :type block-size :initarg :block-size) + (root :accessor root :type high-block :initarg :root :documentation "A list of blocks, starting from the root to the level 1 block.") + (buffer :accessor buffer :initarg :buffer :type buffer) + (eof :accessor eof :initarg :eof :type integer) + (nonce-array :accessor nonce-array :initarg :nonce-array :type simple-array))) + +(defun initialize-nonce-array (level) + (let ((array (make-array (1+ level)))) + (loop for i from 0 to level + do (setf (aref array i) (make-nonce i))) + array)) + +(defun unpad-block (block) + (let ((padding (position #x80 block :from-end t))) + (unless padding + (error 'padding-error)) + (unless (loop for i across (subseq-shared block (1+ padding)) + always (zerop i)) + (error 'padding-error)) + padding)) + +(defun unpad-buffer (buffer) + (with-slots (eof data) buffer + (setf eof + (unpad-block data)))) + +(defun ls (level block-size) + (declare ;; (type (unsigned-byte 8) level) + (type block-size block-size)) + (ecase block-size + (1024 (expt 2 (+ 10 (* level 4)))) + (32768 (expt 2 (+ 15 (* level 9)))))) + +(defun find-eof (root get-block block-size level) + "Find the end of file in a given tree." + ;; The standard states that: + ;; If 64 bytes of zeroes are encountered the rest of the node MUST be checked to be all zeroes + ;; This procedure processes the block from right to left so it's not really applicable here + + (flet ((find-last-reference (block) + (loop for i from (1- (/ block-size 64)) downto 0 + for key-reference = (octets-to-reference-pair (subseq-shared block (* 64 i))) + unless (key-reference-null? key-reference) + return (values key-reference i)))) + (loop with position = 0 + for local-level = level then (1- local-level) + for block = root then (funcall get-block (reference key-reference) (key key-reference) (make-nonce local-level)) + for (key-reference block-pos) = (multiple-value-list (find-last-reference block)) + if (eql 0 local-level) + do (setf position (+ position (unpad-block block))) + and return position + else + do (setf position (+ position (* block-pos (ls (1- local-level) block-size))))))) + +(defun advance-next-block (stream) + "Advance to the next block. This function is called by update-buffer." + (declare (optimize (speed 3) (debug 0))) + (with-slots (buffer position eof block-size root get-block nonce-array) stream + (declare (type integer position eof) + (type block-size block-size) + #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) + (labels ((process-block (blocks mod level) ;; A recursive function that 1+'s each block until the + (declare (type fixnum mod)) + (let* ((current (car blocks)) + (next-pos (setf (pos current) + (mod (the fixnum (1+ (the fixnum (pos current)))) mod)))) + (declare (type high-block current) + (type fixnum next-pos)) + (when (zerop next-pos) ;; if 1+ mod blocks results in a zero, then update the next block + (process-block (cdr blocks) mod (1+ level))) + (let ((kr (octets-to-reference-pair + (subseq-shared (data (cadr blocks)) + (the fixnum (* next-pos 64)))))) + (setf (data current) + (funcall get-block (reference kr) (key kr) (svref nonce-array level))))))) + (process-block (reverse root) (/ block-size 64) 0) ;; process the blocks from level 0 up + ;; setf the buffer data to the level 0 block + (setf (data buffer) + (data (car (last root)))) + ;; if the EOF block is reached, unpad it. + (when (= (- eof (mod eof block-size)) position) + (unpad-buffer buffer))))) + +(defun read-to-seq (sequence buf &key (start 0) (end (length sequence)) stream) + (declare (optimize (speed 3) (debug 0)) + (type integer end start sum) + #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) + (with-slots (data pos eof) buf + (declare (type (integer 0 32768) pos eof) + (type (simple-array (unsigned-byte 8)) data)) + (let ((buffer-bytes (- eof pos)) + (seq-bytes (- end start))) + (declare (dynamic-extent buffer-bytes seq-bytes) + (type integer seq-bytes) + (type (integer 0 32768) buffer-bytes)) + (cond + ((> buffer-bytes seq-bytes) ;; seq is smaller than buffer case + (replace sequence data :start1 start :end1 end :start2 pos) + (setf pos (+ pos seq-bytes) + (pos stream) (+ (pos stream) seq-bytes)) + (+ start seq-bytes)) + ((eql eof (length data)) ;; seq is larger or equal than buffer case + (replace sequence data :start1 start :end1 end :start2 pos) + (setf pos 0 + (pos stream) (+ (pos stream) buffer-bytes)) + (advance-next-block stream) + (read-to-seq sequence buf :start (+ start buffer-bytes) :end end :stream stream)) + (t ;; if there is an eof in the buffer + (replace sequence data :start1 start :end1 end :start2 pos :end2 eof) + (setf pos (+ pos buffer-bytes) + (pos stream) (+ (pos stream) buffer-bytes)) + (+ start buffer-bytes)))))) + + +(defun reupdate-block (stream new-pos) + "Update the blocks of the stream according to new-pos. Used for random access and initialization." + (unless (root stream) + (error 'eof :eof new-pos :position (pos stream))) + (with-slots (block-size root get-block buffer nonce-array eof) stream + (loop with update-tree = nil + for blocks = root then (cdr blocks) + for level = (level (car blocks)) ;; then (decf level) + for position = new-pos then (mod position (ls (1- level) block-size)) ;; local position + for block-position = (floor (/ position (ls (1- level) block-size))) ;; the position of the block + for lower-block = (second blocks) + when (> block-position (/ block-size 64)) + do (error 'eof :eof new-pos :position (pos stream)) + until (eq nil (cdr blocks)) + when (or update-tree (not (eq block-position (pos lower-block)))) + do (let ((rk (octets-to-reference-pair + (subseq-shared (data (car blocks)) + (* 64 block-position))))) + (when (key-reference-null? rk) + (error 'eof :eof new-pos :position (pos stream))) + (setf (data lower-block) (funcall get-block (reference rk) (key rk) (svref nonce-array (1- level))) + (pos lower-block) block-position + update-tree t)) + finally (when update-tree ;; if anything changed + (setf (pos stream) new-pos + (data buffer) (data (car (last root))) + (pos buffer) (mod new-pos block-size)) + (if (= (- eof (mod eof block-size)) new-pos) + (unpad-buffer buffer) + (setf (eof buffer) block-size)))))) + +(defun initialize-high-blocks (level) + (case level + (-1 nil) + (t (cons (make-instance 'high-block :level level :position -1 :data (make-array 0 :element-type '(unsigned-byte 8))) + (initialize-high-blocks (1- level)))))) + + + +(defun eris-decode (read-capability fetch-function &key (cache-capacity 2048)) + "With a given fetch-function, return a stream that decodes the read-capability. + +Fetch-function must be a function with one argument, the reference octet, which +returns a (simple-array (unsigned-byte 8)) containing the block. The block will +be destructively modified, so you MUST provide a fresh array every time. If a +hash-table is used, a (copy-seq) needs to be done on the return value of +gethash. " + (with-slots (level block-size root-reference-pair) read-capability + (let* ((get-block (cached-lambda (:cache-class 'lru-cache + :capacity cache-capacity + :table (make-hash-table :size (1+ cache-capacity) :test #'equalp)) + (reference key &optional nonce) + (let* ((block (funcall fetch-function reference))) + (hash-check block reference) + (if block + (decrypt-block block key nonce) + (error 'missing-block :reference reference))))) + (root (funcall get-block (reference root-reference-pair) (key root-reference-pair) (make-nonce level)))) + ;; "Implementations MUST verify the key appearing in the read capability + ;; if level of encoded content is larger than 0." + ;;(when (> level 0) (hash-check root (key root-reference-pair))) + (case level + ;; Treat level 0 blocks specially, since those are just a single buffer. + (0 (let ((stream + (make-instance 'eris-decode-stream + :buffer (make-instance 'buffer + :data (make-array block-size :element-type '(unsigned-byte 8)) + :pos 0 + :eof -1) + :get-block (lambda (reference key) + (declare (ignore key)) + (error 'missing-block :reference reference)) + :block-size block-size + :root nil + :eof (find-eof root get-block block-size level) + :nonce-array (initialize-nonce-array 0)))) + (replace (data (buffer stream)) root) + (unpad-buffer (buffer stream)) + stream)) + (t (make-instance 'eris-decode-stream + :buffer (make-instance 'buffer + :data (make-array block-size :element-type '(unsigned-byte 8)) + :pos -1 + :eof block-size) + :get-block get-block + :block-size block-size + :root (cons (make-instance 'high-block :level level + :data root + :position 0) + (initialize-high-blocks (1- level))) + :eof (find-eof root get-block block-size level) + :nonce-array (initialize-nonce-array level))))))) + +(defmethod stream-file-position ((stream eris-decode-stream) &optional (set-position nil)) + "Provides the file position of the stream. If the optional second argument is +set, try to move the stream to that position. It may signal an EOF condition if +the new position is beyond the end of file.." + ;; NOTE: this should accept a "file-spec", which I believe is either an int, a + ;; :start or an :end. This only accepts a number. + (with-slots (position block-size buffer eof) stream + (when set-position + (let ((buffer-pos (mod set-position block-size))) + (if (< set-position eof) + (cond + ;; If the pos is within the buffer (and initialized): + ((and (<= 0 (- set-position (- position (pos buffer))) (1- block-size)) + (not (minusp (pos buffer)))) + (setf (pos buffer) buffer-pos + position set-position)) + + (t (reupdate-block stream set-position) + (setf (pos buffer) buffer-pos))) + (error 'eof :eof eof :position position)))) + position)) + +(defmethod stream-read-sequence ((stream eris-decode-stream) seq &optional (start 0) (end (length seq))) + (when (minusp (pos (buffer stream))) + ;; initializes the buffer + (reupdate-block stream (pos stream))) + (with-slots (buffer position) stream + (read-to-seq seq buffer :start start :end (if end end (length seq)) :stream stream))) + +(defmethod stream-read-byte ((stream eris-decode-stream)) + nil) + +(defmethod stream-element-type ((stream eris-decode-stream)) + '(unsigned-byte 8)) + +(defun eris-file-length (stream) + (eof stream)) diff --git a/src/eris.lisp b/src/eris.lisp new file mode 100644 index 0000000..c3bbe5f --- /dev/null +++ b/src/eris.lisp @@ -0,0 +1,244 @@ +;; This file is part of eris-cl. +;; Copyright (C) 2022 Piotr Szarmański + +;; eris-cl 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 3 of the License, or (at your option) any +;; later versqion. + +;; eris-cl 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License along with +;; eris-cl. If not, see <https://www.gnu.org/licenses/>. + +(in-package :eris) + +(defun pad (input block-size) + (declare (type (simple-array (unsigned-byte 8)) input) + (type integer block-size)) + (let* ((pad-size (- block-size (mod (length input) block-size))) + (padded-input (adjust-array input (+ pad-size (length input)) :initial-element 0))) + (replace padded-input input) + (setf (aref padded-input (length input)) #x80) + padded-input)) + +(deftype block-size () + `(member 1024 32768)) + +(defconstant 32kib 32768) +(defconstant 1kib 1024) + +(eval-when + (:execute :load-toplevel :compile-toplevel) + (defclass reference-pair () + ((reference :initarg :reference :accessor reference :type (simple-array (unsigned-byte 8) 32)) + (key :initarg :key :accessor key :type (simple-array (unsigned-byte 8) 32))))) + +(define-constant null-secret (make-array 32 :element-type '(unsigned-byte 8) :initial-element 0) :test #'equalp) + +(defun reference-pair-to-octets (pair buf &optional (start 0)) + (replace buf (reference pair) :start1 start) + (replace buf (key pair) :start1 (+ 32 start))) + +(defun octets-to-reference-pair (octets) + (let ((key (make-array 32 :element-type '(unsigned-byte 8))) + (reference (make-array 32 :element-type '(unsigned-byte 8)))) + (replace reference octets) + (replace key octets :start2 32) + (make-instance 'reference-pair :key key :reference reference))) + + +(defun compute-reference (block) + (declare (type (simple-array (unsigned-byte 8)) block)) + (let ((reference (make-array 32 :element-type '(unsigned-byte 8)))) + (ironclad:digest-sequence :blake2/256 block :digest reference) + reference)) + +(declaim (inline make-nonce)) + +(defun make-nonce (level) + (let ((nonce (make-array 12 :element-type '(unsigned-byte 8) :initial-element 0))) + (setf (aref nonce 0) level) + nonce)) + +(defun encrypt-block (input secret reference) + (declare (type (simple-array (unsigned-byte 8)) input secret reference)) + (let ((mac (ironclad:make-mac :blake2-mac secret :digest-length 32)) + (key (make-array 32 :element-type '(unsigned-byte 8)))) + (ironclad:update-mac mac input) + (ironclad:produce-mac mac :digest key) + ;; NOT the IETF chacha. Need to fix this by patching ironclad. Maybe. + (ironclad:encrypt-in-place (ironclad:make-cipher :chacha :mode :stream :key key + :initialization-vector null-secret) + input) + (ironclad:digest-sequence :blake2/256 input :digest reference) + (make-instance 'reference-pair :key key :reference reference))) + +(defun encrypt-internal-block (input reference nonce) + (declare (type (simple-array (unsigned-byte 8)) input secret reference)) + (let ((key (make-array 32 :element-type '(unsigned-byte 8)))) + (ironclad:digest-sequence :blake2/256 input :digest key) + ;; NOT the IETF chacha. Need to fix this by patching ironclad. Maybe. + (ironclad:encrypt-in-place (ironclad:make-cipher :chacha :mode :stream :key key + :initialization-vector nonce) + input) + (ironclad:digest-sequence :blake2/256 input :digest reference) + (make-instance 'reference-pair :key key :reference reference))) + +(defun decrypt-block (input key &optional (nonce null-secret)) + (ironclad:decrypt-in-place + (ironclad:make-cipher :chacha :mode :stream :key key :initialization-vector nonce) + input) + input) + + +(defclass read-capability () + ((block-size :initarg :block-size + :accessor block-size + :type block-size + :documentation "A value of either 1024 or 1kb blocks.") + (level :initarg :level :accessor level :type (unsigned-byte 8)) + (root-reference-pair :initarg :reference-pair :accessor reference-pair))) + + + +(defun read-capability-to-octets (read-capability) + (declare (type read-capability read-capability)) + (let ((cap (make-array 66 :element-type '(unsigned-byte 8)))) + (case (block-size read-capability) ;; This depends on the version of the standard + (1024 (setf (aref cap 0) #x0a)) + (32768 (setf (aref cap 0) #x0f))) + (setf (aref cap 1) (level read-capability)) + (reference-pair-to-octets (reference-pair read-capability) cap 2))) + +(defun octets-to-read-capability (octets) + (declare (type (simple-array (unsigned-byte 8) (66)) octets)) + (let ((capability (make-instance 'read-capability))) + (setf (block-size capability) + (case (aref octets 0) + (#x0a 1kib) + (#x0f 32kib) + (t (error 'version-mismatch)))) + (setf (level capability) + (aref octets 1)) + (setf (reference-pair capability) + (octets-to-reference-pair (subseq-shared octets 2))) + capability)) + +(defun read-capability-to-urn (capability) + (concatenate 'string + "urn:eris:" + (bytes-to-base32-unpadded (read-capability-to-octets capability)))) + +(defun urn-to-read-capability (urn) + (octets-to-read-capability (base32-to-bytes-unpadded (subseq urn (1+ (position #\: urn :from-end t)))))) + +(defun reference-to-block-urn (reference) + (declare (type (simple-array (unsigned-byte 8) (32)) reference)) + (concatenate 'string "urn:blake2b:" (bytes-to-base32-unpadded reference))) + +(defun block-urn-to-reference (urn) + (declare (type string urn)) + (base32-to-bytes-unpadded (subseq urn (1+ (position #\: urn :from-end t))))) + +(defvar *output-hashmap* nil) + +(defmacro output-block (ref-vector &rest expr) + `(let ((reference (compute-reference block))) + (if hash-output + (unless (gethash reference *output-hashmap*) + (let ((rk (encrypt-block block secret reference))) + (vector-push-extend rk ,ref-vector) + (funcall output-function block (reference rk)) + (setf (gethash reference *output-hashmap*) t))) + (let ((rk (encrypt-block block secret reference))) + (vector-push-extend rk ,ref-vector) + (funcall output-function block (reference rk)))) + ,@expr)) + +(defmacro output-internal-block (ref-vector nonce &rest expr) + `(let ((reference (compute-reference block))) + (if hash-output + (unless (gethash reference *output-hashmap*) + (let ((rk (encrypt-internal-block block reference ,nonce))) + (vector-push-extend rk ,ref-vector) + (funcall output-function block (reference rk)) + (setf (gethash reference *output-hashmap*) t))) + (let ((rk (encrypt-internal-block block reference ,nonce))) + (vector-push-extend rk ,ref-vector) + (funcall output-function block (reference rk)))) + ,@expr)) + +(defgeneric eris-encode (input block-size output-function &key secret hash-output) + (:documentation + "Encode an input into block-size (32kib or 1kib) blocks, that are output using +the function output-function. This function wil be called with two arguments: an +encoded block and a 32-byte reference octet vector. + +An optional 32-byte secret can be passed for additional encryption using the +:secret keyword.")) + +(defmethod eris-encode ((input simple-array) block-size output-function &key (secret null-secret) hash-output) + (declare (type block-size block-size) + (type function output-function) + (type (simple-array (unsigned-byte 8) (32)) secret)) + + (setf input (pad input block-size)) + + (let ((reference-vector (make-array 16 :adjustable t :fill-pointer 0)) + (*output-hashmap* (if hash-output (make-hash-table :test #'equalp) nil))) + (loop for block = (make-array block-size :element-type '(unsigned-byte 8) :initial-element 0) + for i = 0 then (incf i) + until (= (length input) (* i block-size)) + do (progn + (replace block input :start2 (* i block-size)) + (output-block reference-vector nil))) + (eris-create-tree reference-vector block-size output-function :hash-output hash-output))) + +(defmethod eris-encode ((input stream) block-size output-function &key (secret null-secret) hash-output) + (declare (type block-size block-size) + (type function output-function) + (type (simple-array (unsigned-byte 8) (32)) secret)) + (let ((reference-vector (make-array 16 :adjustable t :fill-pointer 0)) + (*output-hashmap* (if hash-output (make-hash-table :test #'equalp) nil))) + (loop for block = (make-array block-size :element-type '(unsigned-byte 8) :initial-element 0) + for bytes-read = (read-sequence block input) + for i = 0 then (incf i) + if (< bytes-read block-size) + do (setf (aref block bytes-read) #x80) + do (output-block reference-vector nil) + until (< bytes-read block-size)) + (eris-create-tree reference-vector block-size output-function :hash-output hash-output))) + +(defun eris-create-tree (reference-vector block-size output-function &key hash-output) + (declare (type block-size block-size) + (type function output-function) + (type (simple-array (unsigned-byte 8) (32)) secret)) + (loop with block-keys = (/ block-size 64) + with level = 0 + with reference-vector-l = (make-array 16 :adjustable t :fill-pointer 0) + for nonce = (make-nonce (1+ level)) + when (eql (length reference-vector) 1) + do (return (make-instance 'read-capability + :reference-pair (aref reference-vector 0) + :level level + :block-size block-size)) + do (progn + (incf level) + ;; loop across the key-reference vector and build the tree + (loop with block = (make-array block-size :element-type '(unsigned-byte 8) :initial-element 0) + for rk across reference-vector + with i = 0 + when (eql i block-keys) + do (output-internal-block reference-vector-l nonce + (setf block (make-array block-size :element-type '(unsigned-byte 8) :initial-element 0) + i 0)) + do (progn (reference-pair-to-octets rk block (* 64 i)) + (incf i)) + finally (unless (zerop i) + ;; If i is zero, then the amount of blocks is just right. Otherwise add a final unfinished block. + (output-internal-block reference-vector-l nonce))) + (setf reference-vector reference-vector-l) + (setf reference-vector-l (make-array 16 :adjustable t :fill-pointer 0))))) diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..b97799c --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,45 @@ +;; This file is part of eris-cl. +;; Copyright (C) 2022 Piotr Szarmański + +;; eris-cl 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 3 of the License, or (at your option) any +;; later versqion. + +;; eris-cl 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License along with +;; eris-cl. If not, see <https://www.gnu.org/licenses/>. + + +(defpackage eris + (:use common-lisp sb-gray alexandria trivia function-cache) + (:export + #:eris-encode + #:eris-decode + #:32kib + #:1kib + #:null-secret + #:*decode-safety-checks* + + #:read-capability-to-urn + #:urn-to-read-capability + #:octets-to-read-capability + #:read-capability-to-octets + + #:reference-to-block-urn + #:block-urn-to-reference + + #:bytes-to-base32-unpadded + #:base32-to-bytes-unpadded + #:base32-to-bytes + #:bytes-to-base32 + + #:eris-condition + #:eof + #:padding-error + #:version-mismatch + #:hash-mismatch + #:invalid-internal-block)) |