Commit 322c03c7 authored by  Hayley Patton's avatar Hayley Patton 🐢

Move server and client out, HASH-OBJECT doesn't rewrite references

parent 8387410b
(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))))))
(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)))))
(defgeneric map-vague-objects (function system)
(:documentation "Call a function repeatedly with each object's name and its owners' names."))
(defgeneric vague-object-stored-p (system name)
(:documentation "Return true if a vague object with name NAME is stored."))
(defgeneric presentable-name-p (system name)
(:documentation "Is the vague object named NAME currently presentable (i.e. has it finished being processed?)"))
(defgeneric (setf presentable-name-p) (presentable? system name)
(:documentation "Set the presentable status of the vague object named NAME.")
(:method :after (presentable? (system netfarm-system) name)
(when presentable?
(decentralise-system:broadcast-metadata
system name 0
(objects-affected-by system name)))))
(defun mark-as-presentable (system name)
"Another way to write (SETF (PRESENTABLE-NAME-P SYSTEM NAME) T)"
(setf (presentable-name-p system name) t))
(defun objects-affected-by (system name)
(let ((affected '()))
(map-computed-values-caused-by
(lambda (target name value)
(declare (ignore name value))
(pushnew target affected :test #'string=))
name system)
affected))
;;; Other interesting block set
(defgeneric add-other-interesting-block (system name)
(:method :after ((system netfarm-system) name)
(decentralise-system:update-system-for-new-interesting-block-predicate
system (list name) '())))
(defgeneric other-interesting-block-p (system name))
(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)))
;;; Only broadcast information about an object after it has gone through the
;;; server machinery
(defmethod decentralise-system:distribute-after-put-block
((system netfarm-system) name version channels)
(declare (ignore name version channels))
'|You can't see it, till it's finished|)
(in-package :netfarm-server)
;;; The first step to resolving an object (verb pending) in Netfarm is to
;;; determine all the dependencies that a vague-object has, and retrieve
;;; those that haven't already been retrieved.
;;; (The resolution process is "recursive" in that we have to have resolved
;;; dependencies as well, but they can be used before scripts have been run.)
(defgeneric add-new-vague-object (system vague-object)
(:method ((system netfarm-system) vague-object)
(let ((dependencies
(remove-if (lambda (name)
(vague-object-stored-p system name))
(netfarm:compute-dependencies vague-object)))
(name (netfarm:vague-object-name vague-object)))
(if (null dependencies)
(mark-as-fulfilled system vague-object)
(dolist (dependency dependencies)
(add-dependency-vertex system name dependency))))))
;;; This thread will take the name of an object which has had all its
;;; dependencies retrieved and remove itself as a dependency for all objects
;;; that depend on it.
(defgeneric dependency-resolution-loop (system)
(:method ((system netfarm-system))
(with-received-message (fulfilled-object
(netfarm-system-fulfilled-objects system))
(remove-dependents system fulfilled-object)
(let ((object
(netfarm:apply-class fulfilled-object
(get-schema system
(netfarm:vague-object-schema-name
fulfilled-object)))))
(when (netfarm:verify-object-signatures object)
(add-initialisation-scripts system object))))))
(in-package :netfarm-server)
(defun compute-initialisation-scripts (object)
(netfarm:netfarm-class-scripts (class-of object)))
;;; The second step to resolving an object in Netfarm is to prepare and run
;;; "initialisation" scripts, which will probably be used most often to create
;;; back references. These are then enqueued to be run on threads which run the
;;; scripts and aggregate all the messages sent.
;;; Each initialisation script receives the object as an argument and can use
;;; the SEND opcode to send another object a message.
(defgeneric add-initialisation-scripts (system object)
(:method ((system netfarm-system) object)
(let ((name (netfarm:hash-object* object))
(scripts (compute-initialisation-scripts object)))
;; If there are no initialisation scripts to be run, no message receival
;; scripts can be run, and thus no further actions are required before
;; the object is presentable.
(when (null scripts)
(mark-as-presentable system name)
(return-from add-initialisation-scripts))
(let ((states
(loop for script in scripts
collect (make-instance 'initialisation-interpreter-state
:subject name
:interpreter (netfarm-scripts:setup-interpreter
script (list object) '(:send))))))
(decentralise-utilities:with-unlocked-box
(table (netfarm-system-object-statuses system))
(setf (gethash name table)
(make-instance 'initialisation-object-status
:name name
:count (length states)
:object object)))
(dolist (state states)
(safe-queue:enqueue state (netfarm-system-interpreters system)))))))
(in-package :netfarm-server)
;;; The third and final step to resolving an object in Netfarm is to prepare and
;;; run "message receival" scripts. Using two stages of scripts allows for
;;; "abstraction" to be made between between different schemas, and for the
;;; receiving object to implement access control, where it may drop messages
;;; from objects which are not authorised to message it.
;;; One interpreter is created per message, and t may use the ADD-COMPUTED-VALUE
;;; opcode to add a computed value to the object it works on behalf of.
(defgeneric make-message-interpreter-state
(system sender-name sender-object message-type &key &allow-other-keys)
(:method ((system netfarm-system) sender-name sender-object
(message-type (eql 'netfarm-scripts:send)) &key target message)
(let ((message-script (netfarm:netfarm-class-message-script
(class-of target))))
(if (null message-script)
nil
(make-instance 'message-interpreter-state
:subject target
:name sender-name
:interpreter (netfarm-scripts:setup-interpreter
message-script
(list target sender-object message)
'(:add-computed-value)))))))
(defgeneric add-message-scripts (system name object messages)
(:method ((system netfarm-system) name object messages)
(let ((states '()))
(dolist (message messages)
(let ((state (apply #'make-message-interpreter-state
system name object message)))
(unless (null state) (push state states))))
(when (null states)
(mark-as-presentable system name)
(return-from add-message-scripts))
(decentralise-utilities:with-unlocked-box
(table (netfarm-system-object-statuses system))
(setf (gethash name table)
(make-instance 'message-object-status
:name name
:count (length states)
:object object)))
(dolist (state states)
(safe-queue:enqueue state (netfarm-system-interpreters system))))))
(in-package :netfarm-server)
(defgeneric run-script-machine (system)
(:method ((system netfarm-system))
(with-received-message
(state (netfarm-system-interpreters system))
(multiple-value-bind (object-status present?)
(decentralise-utilities:with-unlocked-box
(table (netfarm-system-object-statuses system))
(gethash (interpreter-state-name state) table))
(unless present?
;; The status was removed, probably due to an error in another
;; script machine.
(return-from run-script-machine))
(let* ((interpreter (interpreter-state-interpreter state))
(limit (interpreter-state-limit state)))
(handler-case
(netfarm-scripts:run-interpreter interpreter
:cons-limit limit
:cycle-limit limit)
(:no-error (stack finished-interpreter)
(declare (ignore finished-interpreter stack))
(interpreter-state-completed state system object-status))
(error (condition)
(interpreter-state-error state system
condition object-status))))))))
;;; The "scope" of an error caused by an initialisation script is different to
;;; that of a message receival script. If an error is caused by an
;;; initialisation script, the object is dropped and no messages will be sent.
;;; If an error is caused by a message receival script, all other message
;;; receival scripts will still run, and all their side effects will occur.
;;; The side effects created by that script will, however, be dropped.
(macrolet ((maybe-remove-object-status-from-table-and (&body body)
`(when (zerop (object-status-remaining-interpreter-count object-status))
(decentralise-utilities:with-unlocked-box
(table (netfarm-system-object-statuses system))
(remhash (interpreter-state-name state) table)
,@body))))
(defgeneric interpreter-state-completed (state system object-status)
(:method ((state initialisation-interpreter-state) system object-status)
(bt:with-lock-held ((object-status-lock object-status))
(decf (object-status-remaining-interpreter-count object-status))
(setf (initialisation-object-status-messages object-status)
(append (netfarm-scripts:interpreter-side-effects
(interpreter-state-interpreter state))
(initialisation-object-status-messages object-status)))
;;; When all initialisation scripts have been run, create and run
;;; message receival scripts.
(maybe-remove-object-status-from-table-and
(add-message-scripts
system (interpreter-state-name state)
(initialisation-object-status-messages object-status)))))
(:method ((state message-interpreter-state) system object-status)
(bt:with-lock-held ((object-status-lock object-status))
(decf (object-status-remaining-interpreter-count object-status))
(apply-side-effects (netfarm-scripts:interpreter-side-effects
(interpreter-state-interpreter state)))
(maybe-remove-object-status-from-table-and
(mark-as-presentable system (object-status-name object-status))))))
(defgeneric interpreter-state-error (state system condition object-status)
(:method ((state initialisation-interpreter-state)
system condition object-status)
"Drop the object."
(bt:with-lock-held ((object-status-lock object-status))
(decf (object-status-remaining-interpreter-count object-status)))