diff options
Diffstat (limited to 'src/eris.lisp')
| -rw-r--r-- | src/eris.lisp | 244 |
1 files changed, 244 insertions, 0 deletions
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))))) |