Commit 8387410b authored by  Hayley Patton's avatar Hayley Patton 🐢

Separate MOP client code, remove remains of ancient Netfarm designs and "checkpointing"

parent 4f468fc3
(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
......@@ -73,50 +73,11 @@ Providing the class option (:scripts script ...) will attach the initialisation
(:method ((class netfarm-class))
(hash-object* (class->schema class))))
(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))))
(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))
......@@ -172,31 +133,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)
(define-condition parser-error (error)
((name :initarg :name
:reader parser-error-name))
(:report (lambda (condition stream)
(format stream "~s could not be parsed"
(parser-error-name condition)))))
(define-condition parser-bad-segment-count (parser-error)
((count :initarg :count :reader parser-error-segment-count))
(:report (lambda (condition stream)
(format stream "~d segment~:p ~:*~[were~;was~;were~] provided, not 3 or 4"
(parser-error-segment-count condition)))))
(define-condition parser-empty-line (parser-error)
((key :initarg :key :reader parser-error-key))
(:report (lambda (condition stream)
(format stream "The key ~a was provided with no values"
(render (parser-error-key condition))))))
(define-condition parser-bad-signature (parser-error)
((signature :initarg :signature :reader parser-bad-signature-signature))
(:report (lambda (condition stream)
(format stream "The signature given is invalid: ~s"
(parser-bad-signature-signature condition)))))
(define-condition parser-codecs-in-key (parser-error)
((atom :initarg :atom :reader parser-error-key))
(:report (lambda (condition stream)
(format stream "A codec was encountered in a slot name: ~s"
(parser-error-key condition)))))
(define-condition schema-error ()
())
(define-condition netfarm-slot-missing (schema-error)
((instance :initarg :instance :reader schema-slot-missing-instance)
(slot-name :initarg :slot-name :reader schema-slot-missing-slot-name))
(:report (lambda (condition stream)
(format stream "The slot ~s is missing in ~s"
(schema-slot-missing-slot-name condition)
(schema-slot-missing-instance condition)))))
......@@ -6,13 +6,16 @@
:version "0.1.0"
:components ((:file "package")
(:file "macros")
(:file "conditions")
(:module "Codecs"
:depends-on ("package" "macros")
:components ((:file "base64")
(:file "codecs")))
(:module "Objects"
:depends-on ("package" "macros")
:components ((:file "hash")
(:file "mop")
(:module "MOP"
:components ((:file "netfarm-class")
(:file "netfarm-slot")))
(:file "rewrite-references")
(:file "objects")
(:file "schema")
......@@ -21,6 +24,7 @@
(:file "computed-values")
(:file "deep-copy")))
(:module "Scripts"
:depends-on ("Objects")
:components ((:file "package")
(:module "Script-machine"
:components ((:file "conditions")
......@@ -35,10 +39,11 @@
(:file "assemble")
(:file "define-script")))))
(:file "Objects/inbuilt-schemas")
(:file "Objects/checkpointing")
(:module "Text-format"
:depends-on ("Codecs" "Objects")
:components ((:file "new-parser")
(:file "new-renderer")))
(:module "Crypto"
:depends-on ("Text-format")
:components ((:file "hash")
(:file "keys" :depends-on ("hash"))))))
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