Commit 2b77c2e9 authored by  Hayley Patton's avatar Hayley Patton 🐢
parents ddb8a7db cb81e266
(in-package :netfarm-client)
(defclass client (decentralise-kademlia:kademlia-client
netfarm-kademlia:netfarm-kademlia-format-mixin)
())
(asdf:defsystem :netfarm-client
:depends-on (:decentralise2 :netfarm :netfarm-decentralise2)
:components ((:file "package")
(:file "client")
(:file "object")))
(in-package :netfarm-client)
(defun get-parsed-block-data (client name &key timeout)
(netfarm:parse-block
(fourth
(decentralise-client:get-block client name :timeout timeout))
:source (lambda (name)
(find-object client name :timeout timeout))))
(defun find-schema (client name &key timeout)
(or (netfarm:find-netfarm-class name nil)
(let ((schema (get-parsed-block-data client name :timeout timeout)))
(assert (string= (netfarm:vague-object-schema-name schema)
"inbuilt@schema")
(schema)
"The vague object ~s is not a schema"
schema)
(netfarm:apply-class schema (find-class 'netfarm:schema)))))
(defun find-object (client name &key timeout)
(let* ((object (get-parsed-block-data client name :timeout timeout))
(schema-name (netfarm:vague-object-schema-name object))
(class (find-schema client schema-name :timeout timeout)))
(netfarm:apply-class object class)))
(defun save-single-object (client object &key timeout)
(let ((name (netfarm:bytes->base64 (netfarm:hash-object object))))
(unless (decentralise-client:client-has-block-p client name)
(decentralise-client:put-block client name 0 '()
(netfarm:render-object object)
:timeout timeout))))
(defun save-object (client object)
(netfarm:map-objects (lambda (object)
(save-single-object client object))
object)
(netfarm:hash-object* object))
(defpackage :netfarm-client
(:use :cl)
(:export #:client #:save-object #:find-object #:save-single-object))
(defpackage :netfarm-kademlia
(:use :cl)
(:export #:netfarm-kademlia-format-mixin))
(in-package :netfarm-kademlia)
(defclass netfarm-kademlia-format-mixin
(decentralise-kademlia:kademlia-mixin)
())
(defun byte-array-to-integer (byte-array)
(loop with n = 0
for byte across byte-array
do (setf n (logior (ash n 8)
byte))
finally (return n)))
(defmethod decentralise-kademlia:parse-hash-name
((kademlia netfarm-kademlia-format-mixin) name)
(values
(ignore-errors
(byte-array-to-integer
(s-base64:decode-base64-bytes
(make-string-input-stream name))))))
......@@ -76,12 +76,12 @@
(defun verify-object-hash (object hash)
"Verify a total hash as generated by HASH-OBJECT."
(let ((hash (alexandria:copy-array (subseq hash 0 32)
:element-type '(unsigned-byte 8)
:fill-pointer nil
:adjustable nil)))
(ironclad:constant-time-equal hash
(hash-object object))))
(let ((their-hash (alexandria:copy-array (subseq hash 0 32)
:element-type '(unsigned-byte 8)
:fill-pointer nil
:adjustable nil))
(our-hash (hash-object object)))
(ironclad:constant-time-equal their-hash our-hash)))
;;; Pronounceable verification codes.
;; Not dissimilar to https://github.com/deoxxa/proquint/blob/master/encode.js
......
(in-package :netfarm)
;;; The new, MOP-backed, Netfarm object implementation.
(defgeneric netfarm-class-scripts (class)
(:method ((class standard-class)) '()))
(defgeneric netfarm-class-message-script (class)
......@@ -9,6 +7,8 @@
(defgeneric netfarm-class-presentation-script (class)
(:method ((class standard-class)) nil))
;;; The new, MOP-backed, Netfarm object implementation.
(defclass netfarm-class (standard-class)
((presentation-script :initform nil :initarg
:presentation-script
......@@ -86,38 +86,11 @@ Providing the class option (:scripts script ...) will attach the initialisation
(defclass netfarm-computed-slot (netfarm-slot)
())
(defmethod initialize-instance :around ((slot netfarm-computed-slot)
&rest rest
&key initform name)
(unless (null initform)
(error "Cannot supply an initform for the computed slot ~s"
name))
(apply #'call-next-method slot
:initform '()
:initfunction (constantly '())
rest))
(defmethod initialize-instance :after ((slot netfarm-slot) &key)
;; Generate a netfarm-slot name from the slot's symbol-name.
(unless (slot-boundp slot 'netfarm-name)
(setf (slot-value slot 'netfarm-name)
(string-downcase (closer-mop:slot-definition-name slot)))))
(defmethod closer-mop:direct-slot-definition-class ((class netfarm-class) &rest initargs)
(declare (ignore class))
(destructuring-bind (&key computed &allow-other-keys) initargs
(if computed
(find-class 'netfarm-computed-slot)
(find-class 'netfarm-slot))))
(macrolet ((mht () '(make-hash-table :test 'equal)))
(defclass object ()
((signatures :initarg :signatures :initform nil :accessor object-signatures)
(metadata :initform (mht) :initarg :metadata :reader object-metadata)
(source :initarg :source :initform nil :accessor object-source)
(last-hash :initform nil
:accessor object-last-hash))))
(defclass object ()
((metadata :initarg :metadata :initform (make-hash-table :test 'equal)
:reader object-metadata)
(signatures :initarg :signatures :initform nil :accessor object-signatures)
(source :initarg :source :initform nil :accessor object-source)))
(defmethod closer-mop:class-direct-superclasses ((class netfarm-class))
(append (remove (find-class 'standard-object) (call-next-method))
......@@ -173,31 +146,3 @@ Providing the class option (:scripts script ...) will attach the initialisation
(maybe-add-class-slots class))
(setf (slot-value class 'slot-table) slot-table
(slot-value class 'computed-slot-table) computed-slot-table))))
(declaim (inline find-netfarm-slot map-slots
find-netfarm-computed-slot map-computed-slots))
(defun find-netfarm-slot (class slot-name)
(etypecase slot-name
(symbol (setf slot-name (string-downcase slot-name)))
(string))
(string-gethash (netfarm-class-slot-table class) slot-name))
(defun map-slots (function class)
"Call the function with each slot name and definition in the class."
(let ((table (netfarm-class-slot-table class)))
(loop for bucket across table
do (loop for (name . definition) in bucket
do (funcall function name definition)))))
(defun find-netfarm-computed-slot (class slot-name)
(etypecase slot-name
(symbol (setf slot-name (string-downcase slot-name)))
(string))
(string-gethash (netfarm-class-computed-slot-table class) slot-name))
(defun map-computed-slots (function class)
"Call the function with each computed slot name and definition in the class."
(let ((table (netfarm-class-computed-slot-table class)))
(loop for bucket across table
do (loop for (name . definition) in bucket
do (funcall function name definition)))))
(in-package :netfarm)
(defclass netfarm-slot (closer-mop:standard-direct-slot-definition)
((computed :initarg :computed :initform nil)
(documentation :initarg :documentation
:reader slot-documentation)
(netfarm-name :initarg :netfarm-name
:reader slot-netfarm-name)))
(defmethod print-object ((slot netfarm-slot) stream)
(print-unreadable-object (slot stream :type t)
(format stream "~s" (slot-netfarm-name slot))))
(defclass netfarm-computed-slot (netfarm-slot)
())
(defmethod initialize-instance :around ((slot netfarm-computed-slot)
&rest rest
&key initform name)
(unless (null initform)
(error "Cannot supply an initform for the computed slot ~s"
name))
(apply #'call-next-method slot
:initform '()
:initfunction (constantly '())
rest))
(defmethod initialize-instance :after ((slot netfarm-slot) &key)
;; Generate a netfarm-slot name from the slot's symbol-name.
(unless (slot-boundp slot 'netfarm-name)
(setf (slot-value slot 'netfarm-name)
(string-downcase (closer-mop:slot-definition-name slot)))))
(defmethod closer-mop:direct-slot-definition-class ((class netfarm-class) &rest initargs)
(declare (ignore class))
(destructuring-bind (&key computed &allow-other-keys) initargs
(if computed
(find-class 'netfarm-computed-slot)
(find-class 'netfarm-slot))))
(declaim (inline find-netfarm-slot map-slots
find-netfarm-computed-slot map-computed-slots))
(defun find-netfarm-slot (class slot-name)
"Find the effective slot definition for a Netfarm slot."
(etypecase slot-name
(symbol (setf slot-name (string-downcase slot-name)))
(string))
(string-gethash (netfarm-class-slot-table class) slot-name))
(defun map-slots (function class)
"Call the function with each slot name and effective slot definition in the class."
(let ((table (netfarm-class-slot-table class)))
(loop for bucket across table
do (loop for (name . definition) in bucket
do (funcall function name definition)))))
(defun find-netfarm-computed-slot (class slot-name)
"Find the effective slot definition for a Netfarm computed slot."
(etypecase slot-name
(symbol (setf slot-name (string-downcase slot-name)))
(string))
(string-gethash (netfarm-class-computed-slot-table class) slot-name))
(defun map-computed-slots (function class)
"Call the function with each computed slot name and definition in the class."
(let ((table (netfarm-class-computed-slot-table class)))
(loop for bucket across table
do (loop for (name . definition) in bucket
do (funcall function name definition)))))
(in-package :netfarm)
;;; A kind of "checkpointing" system where we can ask if an object has been
;;; updated since it was last saved, and update the last hash it had when it
;;; gets updated.
(defun object-changed-p (object)
(check-type object object)
(or (null (object-last-hash object))
(some #'/=
(hash-object object)
(object-last-hash object))))
(defun object-set-checkpoint (object)
(setf (object-last-hash object)
(hash-object object)))
(in-package :netfarm)
(defgeneric %deep-copy-object (object callback)
(:method (garbage callback)
(warn "Can't copy ~s" garbage)
(funcall callback garbage)
'())
(:method ((hash-table hash-table) callback)
;; This isn't Netfarm data, but is used for metadata tables, so we have
;; to be able to copy those too.
(let ((new-table (alexandria:copy-hash-table hash-table)))
(funcall callback new-table)
(loop for key being the hash-keys of new-table
for value being the hash-values of new-table
collect (cons value
(lambda (value)
(setf (gethash key new-table) value))))))
(:method ((class class) callback)
(funcall callback class)
'())
(:method ((object object) callback)
(let* ((class (class-of object))
(new-object (allocate-instance class)))
(flet ((update-slot (slot)
(lambda (slot-value)
(setf (closer-mop:slot-value-using-class class new-object
slot)
slot-value))))
(funcall callback new-object)
(loop for slot in (closer-mop:class-slots class)
when (closer-mop:slot-boundp-using-class class object slot)
collect (cons (closer-mop:slot-value-using-class class
object
slot)
(update-slot slot))))))
(:method ((number number) callback)
(funcall callback number)
'())
(:method ((cons cons) callback)
(let ((new-cons (cons nil nil)))
(funcall callback new-cons)
(list (cons (car cons)
(lambda (car)
(setf (car new-cons) car)))
(cons (cdr cons)
(lambda (cdr)
(setf (cdr new-cons) cdr))))))
(:method ((vector vector) callback)
(funcall callback (alexandria:copy-array vector))
'())
(:method ((null null) callback)
(funcall callback '())
'()))
(defun deep-copy-object (object)
;; This deep copying algorithm uses an auxiliary stack that is a list of
;; conses, each with an object to copy in the CAR and a function to call
;; with the shallow-copied object in the CDR.
(loop with copied-object = nil
with cache = (make-hash-table :test 'eql)
with stack = (list
(cons object
(lambda (new-object)
(setf copied-object new-object))))
until (null stack)
do (destructuring-bind (object-to-copy . callback)
(pop stack)
(multiple-value-bind (already-copied-object present?)
(gethash object-to-copy cache)
(if present?
(funcall callback already-copied-object)
(setf stack (append (%deep-copy-object object-to-copy callback)
stack)))))
finally (return-from deep-copy-object copied-object)))
(in-package :netfarm)
;;; A class for definining inbuilt Netfarm classes (which have names that are
;;; not hash names).
(defclass inbuilt-netfarm-class (netfarm-class)
((names :initarg :schema-names :reader netfarm-class-schema-names)))
(defmethod initialize-instance :after ((class inbuilt-netfarm-class) &key)
(dolist (name (netfarm-class-schema-names class))
(setf (gethash name *netfarm-classes*) class)))
(defmethod netfarm-class-name ((class inbuilt-netfarm-class))
(if (null (netfarm-class-schema-names class))
(call-next-method)
(first (netfarm-class-schema-names class))))
(in-package :netfarm)
;;; Inbuilt objects (not classes)
(defvar *objects*
(trivial-garbage:make-weak-hash-table :test 'equal
:weakness :value
:weakness-matters t)
"A table that maps hashes to inbuilt objects.")
(defun pin-object (object)
"Mark an object as \"inbuilt\", allowing it to be retrieved via INBUILT-OBJECT."
(setf (gethash (hash-object* object) *objects*)
object))
(defun inbuilt-object (hash)
"Returns the inbuilt object with given hash, or returns NIL if there isn't such an object."
(values (gethash hash *objects*)))
;;; Inbuilt classes
(defvar *netfarm-classes*
(trivial-garbage:make-weak-hash-table :test 'equal
:weakness :value
:weakness-matters nil)
"A table that maps schema hashes to Netfarm classes.")
(defclass inbuilt-netfarm-class (netfarm-class)
((names :initarg :schema-names :reader netfarm-class-schema-names))
(:documentation "A class for definining inbuilt Netfarm classes (which have names that are not hash names). Don't ever ever ever use this outside of the Netfarm system definition, or you will create inconsistent state w.r.t the rest of the world and no one will like you."))
(defmethod initialize-instance :after ((class inbuilt-netfarm-class) &key)
(dolist (name (netfarm-class-schema-names class))
(setf (gethash name *netfarm-classes*) class)))
(defmethod netfarm-class-name ((class inbuilt-netfarm-class))
(first (netfarm-class-schema-names class)))
;;; Hash consing class->schema
(defvar *schemas*
(trivial-garbage:make-weak-hash-table :test 'eq
:weakness :value
:weakness-matters nil)
"A table that maps Netfarm classes to schemas.")
(in-package :netfarm)
(defvar *rewrite-references?* t)
;;; Methods to automagically rewrite object graphs in slots to remove references.
(defun overwrite-instance (target source)
......@@ -29,7 +31,8 @@
(declaim (inline maybe-rewrite-graph))
(defun maybe-rewrite-graph (object graph-cons)
(when (not (car graph-cons))
(when (and (not (car graph-cons))
*rewrite-references?*)
(rewrite-graph (cdr graph-cons) (object-source object))
(setf (car graph-cons) t))
(cdr graph-cons))
......
(in-package :netfarm-server)
(decentralise-system:define-simple-error incorrect-hash)
(defun decode-base64-string (string)
(with-input-from-string (s string)
(s-base64:decode-base64-bytes s)))
(defmethod decentralise-system:put-block
((system netfarm-system) name version channels data)
(declare (ignore version channels))
(let* ((vague-object (netfarm:parse-block data :name name)))
(clrhash (netfarm:vague-object-computed-values vague-object))
(if (netfarm:verify-object-hash vague-object
(decode-base64-string name))
(add-new-vague-object system vague-object)
(error 'incorrect-hash))))
(defmethod decentralise-system:get-block
((system netfarm-system) name)
(if (and (vague-object-stored-p system name)
(presentable-name-p system name))
(values 0
(objects-affected-by system name)
(netfarm:render-object
(get-vague-object system name)))
(error 'decentralise-system:not-found :name name)))
(defmethod decentralise-system:map-blocks
(function (system netfarm-system))
(map-vague-objects
(lambda (name signatures)
(declare (ignore signatures))
(when (presentable-name-p system name)
(funcall function name 0 '())))
system))
(defmethod decentralise-system:interesting-block-p
((system netfarm-system) name version channels)
(declare (ignore version channels))
(or (other-interesting-block-p system name)
(call-next-method)))
(defmethod decentralise-system:start-system :after ((system netfarm-system))
"Start auxiliary threads that resolve Netfarm objects."
(setf (netfarm-system-worker-threads system)
(loop for function in (compute-threads system)
collect (bt:make-thread (funcall-loop function system)))))
(defmethod decentralise-system:distribute-after-put-block
((system netfarm-system) name version channels)
"Only broadcast information about an object after it has gone through the resolution machinery."
(declare (ignore name version channels))
'|You can't see it, till it's finished|)
(in-package :netfarm-server)
;;; Dependency graph storage protocol
(defgeneric add-dependency-vertex (system dependent dependency)
(:documentation "Add a dependency vertex to the dependency graph to the system.")
(:method :after ((system netfarm-system) dependent dependency)
(declare (ignore dependent))
(unless (decentralise-system:interesting-block-p system dependency 0 '())
(add-other-interesting-block system dependency))))
(decentralise-utilities:defexpectation add-dependency-vertex
(system (dependent string) (dependency string)))
(defgeneric remove-dependents (system dependency)
(:documentation "Remove all dependency vertices from the dependency graph of the system where the dependency is DEPENDENCY.")
(:method :around ((system netfarm-system) dependency)
(let ((dependents '()))
(map-dependents
(lambda (dependent) (push dependent dependents))
system dependency)
(call-next-method)
(dolist (dependent dependents)
(when (no-dependencies-p system dependent)
(mark-as-fulfilled system dependent))))))
(defgeneric map-dependents (function system dependency)
(:documentation "Repeatedly call FUNCTION with the names of objects that are dependent on the dependency."))
(defgeneric map-dependencies (function system dependent)
(:documentation "Repeatedly call FUNCTION with the names of objects that are dependencies of the dependent."))
(defgeneric no-dependencies-p (system name)
(:documentation "Return true if the vague object named NAME has no dependencies.
A simple method is provided for this generic function, but it may be faster to provide your own method.")
(:method ((system netfarm-system) name)
(map-dependencies (lambda (dep)
(declare (ignore dep))
(return-from no-dependencies-p nil))
system name)
t))
(defun mark-as-fulfilled (system vague-object)
(safe-queue:mailbox-send-message (netfarm-system-fulfilled-objects system)
vague-object))
(in-package :netfarm-server)
(defclass object-status ()
((lock :initform (bt:make-lock "OBJECT-STATUS lock")
:reader object-status-lock)
(object :initarg :object :reader object-status-object)
(count :initarg :count
:reader object-status-remaining-interpreter-count)
(name :initarg :name :reader object-status-name))
(:documentation "A description of the status of an object as initialization and message-response scripts are ran on its behalf."))
(defclass initialisation-object-status (object-status)
((messages :initform '() :accessor initialisation-object-status-messages)))
(defclass message-object-status (object-status)
())
(defclass interpreter-state ()
((interpreter :initarg :interpreter :reader interpreter-state-interpreter)
(name :initarg :name :reader interpreter-state-name)))
(defclass initialisation-interpreter-state (interpreter-state)
())
(defclass message-interpreter-state (interpreter-state)
((subject :initarg :subject :reader interpreter-state-subject)))
(defgeneric interpreter-state-limit (state)
(:method ((state initialisation-interpreter-state))
100000)
(:method ((state message-interpreter-state))
1000))
(in-package :netfarm-server)
(defclass netfarm-system (netfarm-kademlia:netfarm-kademlia-format-mixin
decentralise-kademlia:kademlia-system-mixin
decentralise-system:standard-system)
((fulfilled-object-mailbox :initform (safe-queue:make-mailbox)
:reader netfarm-system-fulfilled-objects)
(interpreter-mailbox :initform (safe-queue:make-mailbox)
:reader netfarm-system-interpreters)
(object-statuses :initform (decentralise-utilities:make-locked-box
:value (make-hash-table :test 'equal))
:reader netfarm-system-object-statuses)
(worker-threads :initform '()
:accessor netfarm-system-worker-threads)))
;;; Vague object storage
(define-condition vague-object-not-found (error)
((name :initarg :name :reader vague-object-not-found-name)))
(defgeneric put-vague-object (system vague-object)
(:documentation "Write a vague object to the system's database.")
(:method :before (system vague-object)
(assert (not (null (netfarm:vague-object-name vague-object))))))
(defgeneric get-vague-object (system name)
(:documentation "Get a vague object (or raise a condition of type vague-object-not-found) from the system's database.")
(:method :before (system name)
(assert (stringp name))))
(defun get-schema (system name)
(let ((vague-object (get-vague-object system name)))
(netfarm:apply-class vague-object (find-class 'netfarm:schema))))
(defun get-object (system name)
(let* ((object (get-vague-object system name))
(schema-name (netfarm:vague-object-schema-name object)))
(setf (netfarm:vague-object-source object)
(lambda (name)
(get-object system name)))
(let ((class (netfarm:find-netfarm-class schema-name nil)))
(if (null class)
(let ((schema (get-schema system schema-name)))
(netfarm:apply-class object (netfarm:schema->class schema)))
(netfarm:apply-class object class)))))