Commit 3ba044eb authored by  Hayley Patton's avatar Hayley Patton 🐢

Introduce hash caching, and add a general 'datum' computed slot for users

parent 6d614997
Pipeline #1457 passed with stage
in 5 minutes and 5 seconds
......@@ -16,8 +16,30 @@
(update-digest digest vector)))
(produce-digest digest)))
(defvar *hash-cache-lock*)
(defvar *hash-cache* nil)
(defmacro with-hash-cache (() &body body)
"Allow Netfarm to cache hashes in the body."
`(let ((*hash-cache-lock* (bt:make-lock "Hash cache lock"))
(*hash-cache* (trivial-garbage:make-weak-hash-table :weakness :key)))
,@body))
(defmacro with-lexical-hash-cache (() &body body)
(alexandria:with-gensyms (hash-cache hash-cache-lock)
`(let ((,hash-cache-lock *hash-cache-lock*)
(,hash-cache *hash-cache*))
(macrolet ((with-restored-lexical-hash-cache (() &body body)
`(let ((*hash-cache* ,',hash-cache)
(*hash-cache-lock* ,',hash-cache-lock))
,@body)))
,@body))))
(defgeneric hash-object (object)
(:documentation "Generate a hash for an object, including its signatures but not computed values.")
(:documentation "Generate a binary-hash for an object, including its signatures but not computed values.")
(:method ((schema schema))
(if (null (schema-inbuilt-name schema))
(call-next-method)
(error "Cannot binary-hash an inbuilt schema")))
(:method ((object object))
(base-hash-object object))
(:method ((vague-object vague-object))
......@@ -25,9 +47,25 @@
(:method ((reference reference))
(base64->bytes (reference-hash reference))))
(defun hash-object* (object)
"Generate a hash for an object using HASH-OBJECT, but then base64-encode it. This seems common enough to deserve a function."
(bytes->base64 (hash-object object)))
(defgeneric hash-object* (object)
(:documentation "Generate a text-hash for an object.")
(:method :around (object)
(cond
((null *hash-cache*) (call-next-method))
((bt:with-lock-held (*hash-cache-lock*) (gethash object *hash-cache*)))
(t (let ((hash (call-next-method)))
(bt:with-lock-held (*hash-cache-lock*)
(setf (gethash object *hash-cache*) hash))))))
(:method ((schema schema))
(if (null (schema-inbuilt-name schema))
(call-next-method)
(schema-inbuilt-name schema)))
(:method ((object object))
(bytes->base64 (hash-object object)))
(:method ((vague-object vague-object))
(bytes->base64 (hash-object vague-object)))
(:method ((reference reference))
(reference-hash reference)))
(defun verify-object-hash (object hash)
"Verify a total hash as generated by HASH-OBJECT."
......
......@@ -2,7 +2,11 @@
;;; Some inbuilt classes.
(defclass schema ()
((slots :initarg :slots :reader schema-slots)
((inbuilt-name :netfarm-name nil
:initarg :inbuilt-name
:initform nil
:reader schema-inbuilt-name)
(slots :initarg :slots :reader schema-slots)
(computed-slots :initarg :computed-slots :reader schema-computed-slots)
(documentation :initarg :documentation :reader schema-documentation)
(presentation-script :initarg :presentation-script :reader schema-presentation-script)
......@@ -17,7 +21,8 @@
(defclass user ()
((sign-key :initarg :sign-key :reader user-sign-key)
(ecdh-key :initarg :ecdh-key :reader user-ecdh-key))
(ecdh-key :initarg :ecdh-key :reader user-ecdh-key)
(datum :computed t :reader user-datum))
(:metaclass inbuilt-netfarm-class)
(:schema-name "inbuilt@user"))
......
......@@ -93,16 +93,24 @@ keys in the vague-object's values table."
in (string-hash-table->alist slot-definition-table)
collect (slot-definition->netfarm-slot name slot-definition)))
(defun make-class-schema (class &rest initargs)
(apply #'make-instance 'schema
:computed-slots (slot-definition-table->slot-definitions
(netfarm-class-computed-slot-table class))
:documentation (documentation class 'type)
:message-script (netfarm-class-message-script class)
:presentation-script (netfarm-class-presentation-script class)
:scripts (netfarm-class-scripts class)
:slots (slot-definition-table->slot-definitions
(netfarm-class-slot-table class))
initargs))
(defgeneric %class->schema (class)
(:method ((class inbuilt-netfarm-class))
(make-class-schema class :inbuilt-name (netfarm-class-name class)))
(:method ((class netfarm-class))
(make-class-schema class)))
(defun class->schema (class)
"Convert a NETFARM-CLASS into a schema. If a schema for this class already exists, it is returned."
(with-cache (class *schemas*)
(make-instance 'schema
:computed-slots (slot-definition-table->slot-definitions
(netfarm-class-computed-slot-table class))
:documentation (documentation class 'type)
:message-script (netfarm-class-message-script class)
:presentation-script (netfarm-class-presentation-script class)
:scripts (netfarm-class-scripts class)
:slots (slot-definition-table->slot-definitions
(netfarm-class-slot-table class)))))
(with-cache (class *schemas*) (%class->schema class)))
......@@ -27,7 +27,8 @@
(script nil :read-only t)
(program-counter 0 :type reasonably-sized-natural)
(variables #() :type (simple-array t (*)) :read-only t)
(program (make-array 0 :element-type '(unsigned-byte 8))
(program (make-array 0 :element-type '(unsigned-byte 8)
:initial-element 0)
:type (simple-array (unsigned-byte 8) (*)))
(call-stack '() :type list)
(data-stack '() :type list)
......
(asdf:defsystem :netfarm
:author "Cooperative of Applied Language"
:depends-on (:alexandria :babel :closer-mop :flexi-streams
:ironclad :s-base64 :split-sequence :trivial-garbage)
:ironclad :s-base64 :split-sequence
:trivial-garbage :bordeaux-threads)
:license "Cooperative Software License v1+"
:version "0.1.0"
:components ((:file "package")
......
......@@ -38,14 +38,9 @@
#:slot-name #:slot-reader-type
#:reference-hash
;; schema
#:schema
#:schema-slots #:schema-scripts
#:schema-allowed-scripts #:schema-presentation-script
#:schema #:schema-slots #:schema-scripts
#:schema-message-scripts #:schema-presentation-script
#:schema->class
#:*user-schema*
#:*schema-schema*
#:*map-schema*
#:find-inbuilt-schema
;; computed values
#:computed-value #:computed-value-cause #:computed-value-value
#:add-computed-value
......@@ -59,13 +54,15 @@
#:keys-exchange-public #:keys-exchange-private
#:symmetric-cipher
#:symmetric-encrypt #:symmetric-decrypt
#:keys
#:keys
;; hashes
#:hash-text #:sign-text
#:hash-object #:hash-object*
#:sign-object #:add-signature
#:verify-text #:verify-object-hash #:verify-object-signatures
#:readable-verifier
#:object->keys #:keys->object
#:with-hash-cache #:with-lexical-hash-cache #:with-restored-lexical-hash-cache
;; codecs
#:define-codec #:make-codec
#:codec-encoder #:codec-decoder
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment