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

Implement creation of message script machines, finalise initialisation and...

Implement creation of message script machines, finalise initialisation and message response script model
parent 8332d4ef
(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)))))
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
:presentation-script :presentation-script
:reader netfarm-class-presentation-script) :reader netfarm-class-presentation-script)
(scripts :initform '() :initarg :scripts :reader netfarm-class-scripts) (scripts :initform '() :initarg :scripts :reader netfarm-class-scripts)
(message-script :initform '() (message-script :initform nil
:initarg :message-script :initarg :message-script
:reader netfarm-class-message-script) :reader netfarm-class-message-script)
(slot-table :reader netfarm-class-slot-table))) (slot-table :reader netfarm-class-slot-table)))
...@@ -4,5 +4,5 @@ ...@@ -4,5 +4,5 @@
#:interpreter #:interpreter-side-effects #:interpreter-cause #:interpreter #:interpreter-side-effects #:interpreter-cause
#:interpreter-instruction-count #:interpreter-cons-count #:interpreter-instruction-count #:interpreter-cons-count
#:run-interpreter #:setup-interpreter #:run-interpreter #:setup-interpreter
#:add-computed-value #:add-computed-value #:send
#:add-object-to-interpreter #:get-object #:get-object-name)) #:add-object-to-interpreter #:get-object #:get-object-name))
...@@ -41,16 +41,14 @@ ...@@ -41,16 +41,14 @@
(or (other-interesting-block-p system name) (or (other-interesting-block-p system name)
(call-next-method))) (call-next-method)))
;;; Start a dependency resolver thread and an interpreter thread with the system
(defmethod decentralise-system:start-system :after ((system netfarm-system)) (defmethod decentralise-system:start-system :after ((system netfarm-system))
"Start auxiliary threads that resolve Netfarm objects."
(setf (netfarm-system-worker-threads system) (setf (netfarm-system-worker-threads system)
(list (bt:make-thread (funcall-loop #'dependency-resolution-step system)) (loop for function in (compute-threads system)
(bt:make-thread (funcall-loop #'interpreter-step 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 (defmethod decentralise-system:distribute-after-put-block
((system netfarm-system) name version channels) ((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)) (declare (ignore name version channels))
'|You can't see it, till it's finished|) '|You can't see it, till it's finished|)
(in-package :netfarm-server) (in-package :netfarm-server)
(defclass object-status () (defclass object-status ()
((remaining-interpreter-count ((lock :initform (bt:make-lock "OBJECT-STATUS lock")
:initarg :remaining-interpreter-count :reader object-status-lock)
:accessor object-status-remaining-interpreter-count) (object :initarg :object :reader object-status-object)
(stage :initarg :stage :accessor object-status-stage))) (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 () (defclass interpreter-state ()
((interpreter :initarg :interpreter :reader interpreter-state-interpreter) ((interpreter :initarg :interpreter :reader interpreter-state-interpreter)
(system :initarg :system :reader interpreter-state-system) (name :initarg :name :reader interpreter-state-name)))
(subject :initarg :subject :reader interpreter-state-name)))
(defclass initialisation-interpreter-state (interpreter-state) (defclass initialisation-interpreter-state (interpreter-state)
()) ())
(defclass message-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))
(:method ((state message-interpreter-state))
(in-package :netfarm-server) (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 (defclass netfarm-system (netfarm-kademlia:netfarm-kademlia-format-mixin
decentralise-kademlia:kademlia-system-mixin decentralise-kademlia:kademlia-system-mixin
decentralise-system:standard-system) decentralise-system:standard-system)
((fulfilled-object-mailbox :initform (safe-queue:make-mailbox) ((fulfilled-object-mailbox :initform (safe-queue:make-mailbox)
:reader netfarm-system-fulfilled-objects) :reader netfarm-system-fulfilled-objects)
(new-interpreter-mailbox :initform (safe-queue:make-mailbox) (interpreter-mailbox :initform (safe-queue:make-mailbox)
:reader netfarm-system-new-interpreters) :reader netfarm-system-interpreters)
(object-statuses :initform (decentralise-utilities:make-locked-box (object-statuses :initform (decentralise-utilities:make-locked-box
:value (make-hash-table :test 'equal) :value (make-hash-table :test 'equal))
:require-locked-read t)
:reader netfarm-system-object-statuses) :reader netfarm-system-object-statuses)
(worker-threads :initform '() (worker-threads :initform '()
:accessor netfarm-system-worker-threads))) :accessor netfarm-system-worker-threads)))
...@@ -57,6 +53,9 @@ ...@@ -57,6 +53,9 @@
(decentralise-system:broadcast-metadata (decentralise-system:broadcast-metadata
system name 0 system name 0
(objects-affected-by system name))))) (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) (defun objects-affected-by (system name)
(let ((affected '())) (let ((affected '()))
...@@ -67,19 +66,6 @@ ...@@ -67,19 +66,6 @@
name system) name system)
affected)) affected))
;;; Thread helpers
(defmacro with-received-message ((name mailbox) &body body)
`(let ((,name (safe-queue:mailbox-receive-message ,mailbox :timeout *timeout*)))
(unless (null ,name)
(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 ;;; Other interesting block set
(defgeneric add-other-interesting-block (system name) (defgeneric add-other-interesting-block (system name)
(:method :after ((system netfarm-system) name) (:method :after ((system netfarm-system) name)
(in-package :netfarm-server) (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) (defgeneric add-new-vague-object (system vague-object)
(:method ((system netfarm-system) vague-object) (:method ((system netfarm-system) vague-object)
(let ((dependencies (let ((dependencies
...@@ -12,6 +17,9 @@ ...@@ -12,6 +17,9 @@
(dolist (dependency dependencies) (dolist (dependency dependencies)
(add-dependency-vertex system name dependency)))))) (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) (defgeneric dependency-resolution-loop (system)
(:method ((system netfarm-system)) (:method ((system netfarm-system))
(with-received-message (fulfilled-object (with-received-message (fulfilled-object
...@@ -3,24 +3,36 @@ ...@@ -3,24 +3,36 @@
(defun compute-initialisation-scripts (object) (defun compute-initialisation-scripts (object)
(netfarm:netfarm-class-scripts (class-of 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) (defgeneric add-initialisation-scripts (system object)
(:method ((system netfarm-system) object) (:method ((system netfarm-system) object)
(let* ((name (netfarm:hash-object* object)) (let ((name (netfarm:hash-object* object))
(scripts (compute-initialisation-scripts object)) (scripts (compute-initialisation-scripts object)))
(states ;; If there are no initialisation scripts to be run, no message receival
(loop for script in scripts ;; scripts can be run, and thus no further actions are required before
collect (make-instance 'initialisation-interpreter-state ;; the object is presentable.
:subject name (when (null scripts)
:system system (mark-as-presentable system name)
:interpreter (netfarm-scripts:setup-interpreter (return-from add-initialisation-scripts))
script (let ((states
(list object) (loop for script in scripts
'(:send)))))) collect (make-instance 'initialisation-interpreter-state
(decentralise-utilities:with-unlocked-box :subject name
(table (netfarm-system-object-statuses system)) :interpreter (netfarm-scripts:setup-interpreter
(setf (gethash name table) script (list object) '(:send))))))
(make-instance 'object-status (decentralise-utilities:with-unlocked-box
:stage :initialization (table (netfarm-system-object-statuses system))
:remaining-interpreter-count (length states)))) (setf (gethash name table)
(dolist (state states) (make-instance 'initialisation-object-status
(safe-queue:enqueue state (netfarm-system-new-interpreters system)))))) :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)
(make-instance 'message-interpreter-state
:subject target
:name sender-name
:interpreter (netfarm-scripts:setup-interpreter
(list target sender-object message)
(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))
(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))
(state (netfarm-system-interpreters system))
(multiple-value-bind (object-status present?)
(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)))
(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))
(table (netfarm-system-object-statuses system))
(remhash (interpreter-state-name state) table)
(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.
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)))
(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)))
(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))
(mark-as-presentable system (object-status-name object-status)))))))
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
:author "The Cooperative of Applied Language" :author "The Cooperative of Applied Language"
:depends-on (:decentralise2 :netfarm :netfarm-decentralise2) :depends-on (:decentralise2 :netfarm :netfarm-decentralise2)
:components ((:file "package") :components ((:file "package")
(:file "thread-helpers")
(:module "Protocol" (:module "Protocol"
:components ((:file "system") :components ((:file "system")
(:file "dependency-graph") (:file "dependency-graph")
(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)
(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))))
...@@ -17,7 +17,8 @@ ...@@ -17,7 +17,8 @@
(:file "objects") (:file "objects")
(:file "schema") (:file "schema")
(:file "type-specifiers") (:file "type-specifiers")
(:file "inbuilt-netfarm-class"))) (:file "inbuilt-netfarm-class")
(:file "computed-values")))
(:module "Scripts" (:module "Scripts"
:components ((:file "package") :components ((:file "package")
(:module "Script-machine" (:module "Script-machine"
...@@ -8,7 +8,7 @@ ...@@ -8,7 +8,7 @@
#:*reader-depth* #:*reader-depth*
#:base64->bytes #:bytes->base64 #:base64->bytes #:bytes->base64
;; objects ;; 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-presentation-script
#:netfarm-class-name #:netfarm-class-name
#:object-value #:set-object-value #:object-makunbound #:object-boundp #:object-value #:set-object-value #:object-makunbound #:object-boundp
...@@ -44,6 +44,9 @@ ...@@ -44,6 +44,9 @@
#:*schema-schema* #:*schema-schema*
#:*map-schema* #:*map-schema*
#:find-inbuilt-schema #:find-inbuilt-schema
;; computed values
#:computed-value #:computed-value-cause-object #:computed-value-cause-script
;; inbuilt classes ;; inbuilt classes
#:user #:schema #:user #:schema
#:user-map #:user-map-antitriples #:user-map-triples #:user-map-delegates #:user-map #:user-map-antitriples #:user-map-triples #:user-map-delegates
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