Enhance flexibility of the PERSISTENT-SLOTS protocol

- Use PERSISTENT-SLOTS for TENANT and PROJECT.
- Use a property list to convey information instead
  of mixing positional parameters and named properties.

src/poc.lisp

@@ -91,7 +91,8 @@
   'make-cloud-vendor)
 
 (defmethod persistent-slots append ((instance cloud-vendor))
-  '((:credential credential)))
+  '((:initarg :credential
+     :slot-name credential)))
 
 
 ;;;;
@@ -149,7 +150,8 @@ This sets *TENANT* and *PROJECT* to work on the POC."
   'make-private-network)
 
 (defmethod persistent-slots append ((instance private-network))
-  '((:cloud-vendor steward)))
+  '((:initarg :cloud-vendor
+     :slot-name steward)))
 
 
 ;;;;
@@ -183,9 +185,12 @@ This sets *TENANT* and *PROJECT* to work on the POC."
   'make-container-image)
 
 (defmethod persistent-slots append ((instance container-image))
-  '((:cloud-vendor steward)
-    (:repository repository)
-    (:tag tag)))
+  '((:initarg :cloud-vendor
+     :slot-name steward)
+    (:initarg :repository
+     :slot-name repository)
+    (:initarg :tag
+     :slot-name tag)))
 
 
 ;;;;
@@ -212,7 +217,8 @@ This sets *TENANT* and *PROJECT* to work on the POC."
   'make-container-image-registry)
 
 (defmethod persistent-slots append ((instance container-image-registry))
-  '((:cloud-vendor steward)))
+  '((:initarg :cloud-vendor
+     :slot-name steward)))
 
 (defun find-container-image (&key image-registry repository tag)
   "Find a container image in IMAGE-REGISTRY with the given properties."
@@ -251,8 +257,10 @@ This sets *TENANT* and *PROJECT* to work on the POC."
   'make-container-cluster)
 
 (defmethod persistent-slots append ((instance container-cluster))
-  '((:cloud-vendor steward)
-    (:private-network private-network)))
+  '((:initarg :cloud-vendor
+     :slot-name steward)
+    (:initarg :private-network
+     :slot-name private-network)))
 
 (defmethod resource-prerequisites append ((instance container-cluster))
   (with-slots (private-network) instance
@@ -304,10 +312,14 @@ Allowed values are one of :HTTP, :HTTPS, :TCP.")
   'make-container-service)
 
 (defmethod persistent-slots append ((instance container-service))
-  '((:cloud-vendor steward)
-    (:cluster cluster)
-    (:image image)
-    (:protocol protocol)))
+  '((:initarg :cloud-vendor
+     :slot-name steward)
+    (:initarg :cluster
+     :slot-name cluster)
+    (:initarg :image
+     :slot-name image)
+    (:initarg :protocol
+     :slot-name protocol)))
 
 (defmethod resource-prerequisites append ((instance container-service))
   (with-slots (cluster image) instance
@@ -347,9 +359,12 @@ Allowed values are one of :HTTP, :HTTPS, :TCP.")
   'make-public-load-balancer)
 
 (defmethod persistent-slots append ((instance public-load-balancer))
-  '((:cloud-vendor steward)
-    (:private-network private-network)
-    (:services services)))
+    '((:initarg :cloud-vendor
+     :slot-name steward)
+    (:initarg :private-network
+     :slot-name private-network)
+    (:initarg :services
+     :slot-name services)))
 
 (defmethod resource-prerequisites append ((instance public-load-balancer))
   (with-slots (private-network services) instance
@@ -424,12 +439,18 @@ defined, provisioned and modified as a unit."))
   'make-infrastructure-stack)
 
 (defmethod persistent-slots append ((instance infrastructure-stack))
-  '((:tenant tenant)
-    (:project project)
-    (:name name)
-    (:displayname displayname)
-    (:description description)
-    (:resources resources)))
+  '((:initarg :tenant
+     :slot-name tenant)
+    (:initarg :project
+     :slot-name project)
+    (:initarg :name
+     :slot-name name)
+    (:initarg :displayname
+     :slot-name displayname)
+    (:initarg :description
+     :slot-name description)
+    (:initarg :resources
+     :slot-name resources)))
 
 (defmethod print-object ((instance infrastructure-stack) stream)
   (flet ((print-readably ()

src/project.lisp

@@ -79,10 +79,7 @@ up using `FIND-PROJECT'."
 
 (defmethod print-object ((instance project) stream)
   (flet ((print-readably ()
-	   (write-persistent-object instance stream 'project
-				    '((:tenant tenant)
-				      (:name name)
-				      (:displayname displayname))))
+	   (write-persistent-object instance stream))
 	 (print-unreadably ()
 	   (with-slots (tenant name displayname) instance
 	     (print-unreadable-object (instance stream :type t :identity t)
@@ -94,6 +91,14 @@ up using `FIND-PROJECT'."
 (defmethod persistent-constructor ((class (eql 'project)))
   #'make-project)
 
+(defmethod persistent-slots append ((instance project))
+  '((:initarg :tenant
+     :slot-name tenant)
+    (:initarg :name
+     :slot-name name)
+    (:initarg :displayname
+     :slot-name displayname)))
+
 (defun list-projects (&key (tenant *tenant*))
   "List existing projects."
   (flet ((return-early-if-tenant-does-not-exist ()

src/resource.lisp

@@ -71,11 +71,16 @@ resources. For a given STEWARD, any resource is uniquely identified by its IDENT
   (project (steward instance)))
 
 (defmethod persistent-slots append ((instance resource))
-  '((:name name)
-    (:displayname displayname)
-    (:description description)
-    (:state state)
-    (:identifier identifier)))
+  '((:initarg :name
+     :slot-name name)
+    (:initarg :displayname
+     :slot-name displayname)
+    (:initarg :description
+     :slot-name description)
+    (:initarg :state
+     :slot-name state)
+    (:initarg :identifier
+     :slot-name identifier)))
 
 (defmethod print-object ((instance resource) stream)
   (flet ((print-readably ()
@@ -580,4 +585,35 @@ These resources can be imported."))
 		  resource-class
 		  :identifier identifier)))
 
+
+;;;;
+;;;; Update Resources from a Blueprint
+;;;;
+
+(defun apply-modification-instructions (instructions)
+  "Process resource modifying INSTRUCTIONS.
+The possible INSTRUCTIONS and their semantics are described below:
+
+  :CREATE RESOURCE
+    Create the given RESOURCE.
+
+  :DELETE RESOURCE
+    Delete the given RESOURCE.
+
+  :UPDATE-INSTANCE RESOURCE {SLOT-NAME SLOT-VALUE}*
+    Update the RESOURCE instance so that its slots take the specified values.
+
+  :UPDATE-RESOURCE RESOURCE
+    Update the underlying RESOURCE so that it reflects the change carried on the INSTANCE.")
+
+(defun prepare-modification-instructions (resource blueprint)
+  "Prepare INSTRUCTIONS to modify RESOURCE to resemble the BLUEPRINT.
+When applied the instruction must update the RESOURCE instance so that its slots take the
+values of the slots of BLUEPRINT.  Some slots are excluded from the process, such as the
+STATE and the IDENTIFIER."
+  (list
+   (list :delete resource)
+   (list :update-instance resource blueprint)
+   (list :create resource)))
+
 ;;;; End of file `resource.lisp'

src/steward.lisp

@@ -55,9 +55,12 @@ of infrastructure stacks."))
     (support-initialize-project-slot-with-designator)))
 
 (defmethod persistent-slots append ((instance steward))
-  '((:tenant tenant)
-    (:project project)
-    (:description description)))
+  '((:initarg :tenant
+     :slot-name tenant)
+    (:initarg :project
+     :slot-name project)
+    (:initarg :description
+     :slot-name description)))
 
 (defmethod print-object ((instance steward) stream)
   (flet ((print-readably ()
@@ -148,6 +151,8 @@ that need to interact with several stewards."))
   #'make-composite-steward)
 
 (defmethod persistent-slots append ((instance composite-steward))
-  '((:stewards stewards :presentation #'alexandria:hash-table-plist)))
+  '((:initarg :stewards
+     :slot-name stewards
+     :presentation #'alexandria:hash-table-plist)))
 
 ;;;; End of file `steward.lisp'

src/stewards/simulator.lisp

@@ -46,7 +46,8 @@ new resources."))
   'make-simulator)
 
 (defmethod persistent-slots append ((instance simulator))
-  '((:resource-identifiers resource-identifiers)))
+  '((:initarg :resource-identifiers
+     :slot-name resource-identifiers)))
 
 
 ;;;;

src/tenant.lisp

@@ -57,9 +57,7 @@ up using `FIND-TENANT'."
 
 (defmethod print-object ((instance tenant) stream)
   (flet ((print-readably ()
-	   (write-persistent-object instance stream 'tenant
-				    '((:name name)
-				      (:displayname displayname))))
+	   (write-persistent-object instance stream))
 	 (print-unreadably ()
 	   (with-slots (name displayname) instance
 	     (print-unreadable-object (instance stream :type t :identity t)
@@ -71,6 +69,12 @@ up using `FIND-TENANT'."
 (defmethod persistent-constructor ((class (eql 'tenant)))
   #'make-tenant)
 
+(defmethod persistent-slots append ((instance tenant))
+  '((:initarg :name
+     :slot-name name)
+    (:initarg :displayname
+     :slot-name displayname)))
+
 (defun list-tenants ()
   "List existing tenants."
   (alexandria:hash-table-values *tenant-directory*))

src/utilities.lisp

@@ -111,14 +111,31 @@
 
 (defgeneric persistent-slots (object)
   (:method-combination append)
-  (:documentation "The slot specifications to use when readably printing OBJECT."))
+  (:documentation "The slot specifications to use when readably printing OBJECT.
+The slot specification is a list of slot specification. Each slot specification
+is a plist with the following mandatory members
 
-(defun write-persistent-object (object stream &optional class slot-specs)
+  :INITARG
+    The initarg keyword used by the constructor to construct the instance.
+
+  :SLOT-NAME
+    The name of the corresponding object slot.
+
+The following members are optional:
+
+  :CONFIDENTIAL
+    A boolean marking slots which requires encryption when they are persisted.
+
+  :PRESENTATION
+    When provided, a function used to transform the slot value in a value
+    which can be persisted."))
+
+(defun write-persistent-object (object stream)
   "Readably write persistent OBJECT on STREAM."
   (let ((class
-	  (or class (type-of object)))
+	  (type-of object))
 	(slot-specs
-	  (or slot-specs (persistent-slots object))))
+	  (persistent-slots object)))
     (pprint-logical-block (stream nil :prefix "[" :suffix "]")
       (pprint class stream)
       (write-char #\Space stream)
@@ -127,8 +144,8 @@
       (loop :for slot-spec-iterator :on slot-specs
 	    :for slot-spec = (first slot-spec-iterator)
 	    :for lastp = (not (rest slot-spec-iterator))
-	    :do (destructuring-bind (initarg slot-name &key sensitive-p (presentation 'identity)) slot-spec
-		  (declare (ignore sensitive-p))
+	    :do (destructuring-bind (&key initarg slot-name confidential (presentation 'identity)) slot-spec
+		  (declare (ignore confidential))
 		  (when (slot-boundp object slot-name)
 		    (pprint-logical-block (stream nil)
 		      (pprint initarg stream)

testsuite/poc.lisp

@@ -72,7 +72,7 @@ resources is usually longer than those of Common Lisp sessions."
 		  (assert-eq (cid:persistent-constructor (type-of object1))
 			     (cid:persistent-constructor (type-of object2)))
 		  (loop :for slot-spec :in (cid:persistent-slots object1)
-			:for slot-name = (second slot-spec)
+			:for slot-name = (getf slot-spec :slot-name)
 			:do (check-structural-equality
 			     (slot-value object1 slot-name)
 			     (slot-value object2 slot-name))))))