From 56d3ca4cf14ac1b2bac9c866daa98cdb803915fa Mon Sep 17 00:00:00 2001
From: Piotr Szarmanski
Date: Wed, 21 Sep 2022 22:50:14 +0200
Subject: Initial commit.
---
src/base32.lisp | 191 +++++++++++++++++++++++++++++++++
src/cache.lisp | 45 ++++++++
src/common.lisp | 10 ++
src/conditions.lisp | 53 ++++++++++
src/eris-decode.lisp | 291 +++++++++++++++++++++++++++++++++++++++++++++++++++
src/eris.lisp | 244 ++++++++++++++++++++++++++++++++++++++++++
src/package.lisp | 45 ++++++++
7 files changed, 879 insertions(+)
create mode 100644 src/base32.lisp
create mode 100644 src/cache.lisp
create mode 100644 src/common.lisp
create mode 100644 src/conditions.lisp
create mode 100644 src/eris-decode.lisp
create mode 100644 src/eris.lisp
create mode 100644 src/package.lisp
(limited to 'src')
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 .
+
+(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 .
+
+(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 .
+
+(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 .
+
+
+(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))
--
cgit v1.2.3