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 @@
: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)))
......
......@@ -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))
......@@ -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|)
(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))
(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)
......
(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
......
......@@ -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)))))))
(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)))
(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)))))))
......@@ -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")
......
(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))))
......@@ -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"
......
......@@ -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
......
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