From 3b26594588a8333f1ca595b46dec8dbefe9323f1 Mon Sep 17 00:00:00 2001 From: theemacsshibe Date: Tue, 18 Feb 2020 19:14:21 +1100 Subject: [PATCH] Implement creation of message script machines, finalise initialisation and message response script model --- Code/Objects/computed-values.lisp | 12 +++ Code/Objects/mop.lisp | 2 +- Code/Scripts/package.lisp | 2 +- Code/Server/Protocol/decentralise2.lisp | 10 +-- Code/Server/Protocol/interpreters.lisp | 28 +++++-- Code/Server/Protocol/system.lisp | 26 ++----- Code/Server/Stages/dependency-resolution.lisp | 8 ++ .../initialisation-script-machines.lisp | 50 +++++++----- .../Stages/message-script-machines.lisp | 46 +++++++++++ Code/Server/Stages/script-machine-runner.lisp | 78 +++++++++++++++++++ Code/Server/netfarm-server.asd | 1 + Code/Server/thread-helpers.lisp | 16 ++++ Code/netfarm.asd | 3 +- Code/package.lisp | 5 +- 14 files changed, 231 insertions(+), 56 deletions(-) create mode 100644 Code/Objects/computed-values.lisp create mode 100644 Code/Server/Stages/message-script-machines.lisp create mode 100644 Code/Server/Stages/script-machine-runner.lisp create mode 100644 Code/Server/thread-helpers.lisp diff --git a/Code/Objects/computed-values.lisp b/Code/Objects/computed-values.lisp new file mode 100644 index 0000000..dba81bb --- /dev/null +++ b/Code/Objects/computed-values.lisp @@ -0,0 +1,12 @@ +(in-package :netfarm) + +(define-tuple computed-value () + ((cause) (value)) + "A computed value that was added to an object by another object.") + +(defgeneric add-computed-value (object cause name value) + (:method ((object object) cause name value) + (push (make-instance 'computed-value + :cause cause + :value value) + (gethash name (object-computed-values-table object))))) diff --git a/Code/Objects/mop.lisp b/Code/Objects/mop.lisp index 6451cb5..413c1d7 100644 --- a/Code/Objects/mop.lisp +++ b/Code/Objects/mop.lisp @@ -7,7 +7,7 @@ :presentation-script :reader netfarm-class-presentation-script) (scripts :initform '() :initarg :scripts :reader netfarm-class-scripts) - (message-script :initform '() + (message-script :initform nil :initarg :message-script :reader netfarm-class-message-script) (slot-table :reader netfarm-class-slot-table))) diff --git a/Code/Scripts/package.lisp b/Code/Scripts/package.lisp index ac752a4..7b4a15c 100644 --- a/Code/Scripts/package.lisp +++ b/Code/Scripts/package.lisp @@ -4,5 +4,5 @@ #:interpreter #:interpreter-side-effects #:interpreter-cause #:interpreter-instruction-count #:interpreter-cons-count #:run-interpreter #:setup-interpreter - #:add-computed-value + #:add-computed-value #:send #:add-object-to-interpreter #:get-object #:get-object-name)) diff --git a/Code/Server/Protocol/decentralise2.lisp b/Code/Server/Protocol/decentralise2.lisp index 47090de..0071e9c 100644 --- a/Code/Server/Protocol/decentralise2.lisp +++ b/Code/Server/Protocol/decentralise2.lisp @@ -41,16 +41,14 @@ (or (other-interesting-block-p system name) (call-next-method))) -;;; Start a dependency resolver thread and an interpreter thread with the system (defmethod decentralise-system:start-system :after ((system netfarm-system)) + "Start auxiliary threads that resolve Netfarm objects." (setf (netfarm-system-worker-threads system) - (list (bt:make-thread (funcall-loop #'dependency-resolution-step system)) - (bt:make-thread (funcall-loop #'interpreter-step system))))) + (loop for function in (compute-threads system) + collect (bt:make-thread (funcall-loop function system))))) - -;;; 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) + "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|) diff --git a/Code/Server/Protocol/interpreters.lisp b/Code/Server/Protocol/interpreters.lisp index 7d38463..9a0f1c7 100644 --- a/Code/Server/Protocol/interpreters.lisp +++ b/Code/Server/Protocol/interpreters.lisp @@ -1,18 +1,32 @@ (in-package :netfarm-server) (defclass object-status () - ((remaining-interpreter-count - :initarg :remaining-interpreter-count - :accessor object-status-remaining-interpreter-count) - (stage :initarg :stage :accessor object-status-stage))) + ((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) - (system :initarg :system :reader interpreter-state-system) - (subject :initarg :subject :reader interpreter-state-name))) + (name :initarg :name :reader interpreter-state-name))) (defclass initialisation-interpreter-state (interpreter-state) ()) (defclass message-interpreter-state (interpreter-state) - ((sender :initarg :sender :reader interpreter-state-sender))) + ((subject :initarg :subject :reader interpreter-state-subject))) + +(defgeneric interpreter-state-limit (state) + (:method ((state initialisation-interpreter-state)) + 100000) + (:method ((state message-interpreter-state)) + 1000)) diff --git a/Code/Server/Protocol/system.lisp b/Code/Server/Protocol/system.lisp index e104468..4947020 100644 --- a/Code/Server/Protocol/system.lisp +++ b/Code/Server/Protocol/system.lisp @@ -1,18 +1,14 @@ (in-package :netfarm-server) -(defvar *timeout* 1 - "A timeout for any looping mailbox readers to use, so that they may be stopped gracefully when control is returned to FUNCALL-LOOP.") - (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) - (new-interpreter-mailbox :initform (safe-queue:make-mailbox) - :reader netfarm-system-new-interpreters) + (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) - :require-locked-read t) + :value (make-hash-table :test 'equal)) :reader netfarm-system-object-statuses) (worker-threads :initform '() :accessor netfarm-system-worker-threads))) @@ -57,6 +53,9 @@ (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 '())) @@ -67,19 +66,6 @@ name system) affected)) -;;; Thread helpers -(defmacro with-received-message ((name mailbox) &body body) - `(let ((,name (safe-queue:mailbox-receive-message ,mailbox :timeout *timeout*))) - (unless (null ,name) - ,@body))) - -(defun funcall-loop (function system) - "A function that calls the function repeatedly with the system until a shutdown is requested." - (lambda () - (loop until (decentralise-system:system-shutdown-request system) - do (funcall function system)))) - - ;;; Other interesting block set (defgeneric add-other-interesting-block (system name) (:method :after ((system netfarm-system) name) diff --git a/Code/Server/Stages/dependency-resolution.lisp b/Code/Server/Stages/dependency-resolution.lisp index 6c83c1e..51e36ba 100644 --- a/Code/Server/Stages/dependency-resolution.lisp +++ b/Code/Server/Stages/dependency-resolution.lisp @@ -1,5 +1,10 @@ (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 @@ -12,6 +17,9 @@ (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 diff --git a/Code/Server/Stages/initialisation-script-machines.lisp b/Code/Server/Stages/initialisation-script-machines.lisp index 8484c02..c4b0a27 100644 --- a/Code/Server/Stages/initialisation-script-machines.lisp +++ b/Code/Server/Stages/initialisation-script-machines.lisp @@ -3,24 +3,36 @@ (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)) - (states - (loop for script in scripts - collect (make-instance 'initialisation-interpreter-state - :subject name - :system system - :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 'object-status - :stage :initialization - :remaining-interpreter-count (length states)))) - (dolist (state states) - (safe-queue:enqueue state (netfarm-system-new-interpreters system)))))) + (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))))))) diff --git a/Code/Server/Stages/message-script-machines.lisp b/Code/Server/Stages/message-script-machines.lisp new file mode 100644 index 0000000..b944c54 --- /dev/null +++ b/Code/Server/Stages/message-script-machines.lisp @@ -0,0 +1,46 @@ +(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)))))) diff --git a/Code/Server/Stages/script-machine-runner.lisp b/Code/Server/Stages/script-machine-runner.lisp new file mode 100644 index 0000000..ab81480 --- /dev/null +++ b/Code/Server/Stages/script-machine-runner.lisp @@ -0,0 +1,78 @@ +(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))) + (decentralise-utilities:with-unlocked-box + (table (netfarm-system-object-statuses system)) + (remhash (interpreter-state-name state) table))) + (:method ((state message-interpreter-state) + system condition object-status) + "Decrement the remaining interpreter count, and move to the next interpreter." + (bt:with-lock-held ((object-status-lock object-status)) + (decf (object-status-remaining-interpreter-count object-status)) + (maybe-remove-object-status-from-table-and + (mark-as-presentable system (object-status-name object-status))))))) diff --git a/Code/Server/netfarm-server.asd b/Code/Server/netfarm-server.asd index 8056bcc..5830515 100644 --- a/Code/Server/netfarm-server.asd +++ b/Code/Server/netfarm-server.asd @@ -2,6 +2,7 @@ :author "The Cooperative of Applied Language" :depends-on (:decentralise2 :netfarm :netfarm-decentralise2) :components ((:file "package") + (:file "thread-helpers") (:module "Protocol" :components ((:file "system") (:file "dependency-graph") diff --git a/Code/Server/thread-helpers.lisp b/Code/Server/thread-helpers.lisp new file mode 100644 index 0000000..4f9ec87 --- /dev/null +++ b/Code/Server/thread-helpers.lisp @@ -0,0 +1,16 @@ +(in-package :netfarm-server) + +(defvar *timeout* 1 + "A timeout for any looping mailbox readers to use, so that they may be stopped gracefully when control is returned to FUNCALL-LOOP.") + +(defmacro with-received-message ((name mailbox) &body body) + "Bind NAME to a message received from MAILBOX. (If there isn't a message after *TIMEOUT* seconds, do nothing.)" + `(let ((,name (safe-queue:mailbox-receive-message ,mailbox :timeout *timeout*))) + (unless (null ,name) + ,@body))) + +(defun funcall-loop (function system) + "A function that calls the function repeatedly with the system until a shutdown is requested." + (lambda () + (loop until (decentralise-system:system-shutdown-request system) + do (funcall function system)))) diff --git a/Code/netfarm.asd b/Code/netfarm.asd index 9dfd657..163bada 100644 --- a/Code/netfarm.asd +++ b/Code/netfarm.asd @@ -17,7 +17,8 @@ (:file "objects") (:file "schema") (:file "type-specifiers") - (:file "inbuilt-netfarm-class"))) + (:file "inbuilt-netfarm-class") + (:file "computed-values"))) (:module "Scripts" :components ((:file "package") (:module "Script-machine" diff --git a/Code/package.lisp b/Code/package.lisp index 3daa7e5..736f0ff 100644 --- a/Code/package.lisp +++ b/Code/package.lisp @@ -8,7 +8,7 @@ #:*reader-depth* #:base64->bytes #:bytes->base64 ;; objects - #:netfarm-class #:netfarm-class-scripts #:netfarm-class-allowed-scripts + #:netfarm-class #:netfarm-class-scripts #:netfarm-class-message-script #:netfarm-class-presentation-script #:netfarm-class-name #:object-value #:set-object-value #:object-makunbound #:object-boundp @@ -44,6 +44,9 @@ #:*schema-schema* #:*map-schema* #:find-inbuilt-schema + ;; computed values + #:computed-value #:computed-value-cause-object #:computed-value-cause-script + #:computed-value-value ;; inbuilt classes #:user #:schema #:user-map #:user-map-antitriples #:user-map-triples #:user-map-delegates -- GitLab