Commit dcccd4b1fd292f207e5847fc19d90fc70b64fcfa

Thomas de Grivel 2018-07-10T12:32:38

fix sorting resources

diff --git a/core/defs.lisp b/core/defs.lisp
index 9aaa643..b8d723c 100644
--- a/core/defs.lisp
+++ b/core/defs.lisp
@@ -76,7 +76,11 @@
    (probes :reader probes-of
 	   :type list)
    (operations :reader operations-of
-               :type list))
+               :type list)
+   (op-properties :initarg :op-properties
+                  :initform ()
+                  :reader op-properties
+                  :type list))
   (:default-initargs :direct-superclasses (list *the-resource-class*)))
 
 (defmethod closer-mop:validate-superclass ((c resource-class)
diff --git a/core/operation.lisp b/core/operation.lisp
index 67478ff..58d151b 100644
--- a/core/operation.lisp
+++ b/core/operation.lisp
@@ -95,14 +95,52 @@
          (push op operations)))
     (nreverse operations)))
 
-(defun sort-operations (operations)
+(defgeneric resource-op-properties (resource))
+(defgeneric op-property-before-p (resource p1 p2))
+(defgeneric operation-before-p (resource op1 op2))
+(defgeneric sort-operations (resource operations))
+
+(trace resource-op-properties
+       op-properties
+       op-property-before-p
+       operation-before-p
+       sort-operations)
+
+(defmethod resource-op-properties ((res resource))
+  (op-properties (class-of res)))
+
+(defmethod op-property-before-p ((res resource) (p1 symbol) (p2 symbol))
+  (dolist (prop (resource-op-properties res))
+    (cond ((endp prop) (return nil))
+          ((eq p1 (first prop)) (return t))
+          ((eq p2 (first prop)) (return nil)))
+    (pop prop)))
+
+(defmethod operation-before-p ((res resource) (op1 operation)
+                               (op2 operation))
+  (declare (type operation op1 op2))
+  (let ((op1-properties (operation-properties op1)))
+    (loop (when (endp op1-properties) (return))
+       (let ((p1 (pop op1-properties))
+             (op2-properties (operation-properties op2))
+             (before-p t))
+         (loop (when (endp op2-properties) (return))
+            (let ((p2 (pop op2-properties)))
+              (unless (op-property-before-p res p1 p2)
+                (setf before-p nil)
+                (return))))
+         (when before-p
+           (return-from operation-before-p t)))))
+  (find op1 (the list (operations-before op2))))
+
+(defmethod sort-operations ((res resource) (operations list))
   (sort operations (lambda (op1 op2)
-                     (find op1 (operations-before op2)))))
+                     (operation-before-p res op1 op2))))
 
 (defmethod operate ((res resource) (plist list))
   (let* ((os (host-os (current-host)))
          (operations (list-operations res plist os))
-         (sorted-ops (sort-operations operations))
+         (sorted-ops (sort-operations res operations))
          (results))
     (loop
        (let* ((op (pop sorted-ops))
diff --git a/core/resource-container.lisp b/core/resource-container.lisp
index 008f6f4..0c15b80 100644
--- a/core/resource-container.lisp
+++ b/core/resource-container.lisp
@@ -46,19 +46,27 @@
 		      parent)
 	child))
 
-(defmacro do-resources ((var) container &body body)
+(defmacro do-resources% ((var) container &body body)
   (let ((x (gensym)))
     `(maphash (lambda (,x ,var)
                 (declare (ignore ,x))
                 ,@body)
               (resource-registry ,container))))
 
-(defmethod child-resources ((res resource-container))
+(defmethod sorted-resources ((res resource-container))
   (let ((resources))
-    (do-resources (child) res
+    (do-resources% (child) res
       (push child resources))
     (sort resources #'resource-before-p)))
 
+(defmacro do-resources ((var) container &body body)
+  (let ((resources (gensym "RESOURCES-")))
+    `(let ((,resources (sorted-resources ,container)))
+       (loop (when (endp ,resources) (return))
+          (let ((,var (pop ,resources)))
+            (declare (type resource ,var))
+            ,@body)))))
+ 
 ;;  Resource container
 
 (defmethod print-object ((rc resource-container) stream)
@@ -78,3 +86,14 @@
 
 (defmethod resource-before-p ((r1 resource) (r2 resource))
   nil)
+
+;;  Sync
+
+(defmethod sync :after ((res resource-container))
+  (with-parent-resource res
+    (let ((sorted-resources (sorted-resources res)))
+      (loop
+         (when (endp sorted-resources)
+           (return))
+         (let ((child (pop sorted-resources)))
+           (sync child))))))
diff --git a/core/resource.lisp b/core/resource.lisp
index c808f3b..782e4b1 100644
--- a/core/resource.lisp
+++ b/core/resource.lisp
@@ -188,7 +188,7 @@
            (host (current-host))
            (os (host-os host))
            (ops (list-operations res plist os))
-           (sorted-ops (sort-operations ops)))
+           (sorted-ops (sort-operations res ops)))
       (loop
          (when (endp sorted-ops)
            (return))
@@ -198,17 +198,7 @@
                 (op-fun (operation-generic-function op)))
            (apply op-fun res os op-plist)
            (clear-probed res op-keys)
-           (sync-op host res op op-keys op-plist os))))))
-
-(defmethod sync ((res resource-container))
-  (call-next-method)
-  (with-parent-resource res
-    (let ((child-resources (child-resources res)))
-      (loop
-         (when (endp child-resources)
-           (return))
-         (let ((child (pop child-resources)))
-           (sync child))))))
+           (sync-check host res op op-keys op-plist os))))))
 
 (defmethod sync ((host host))
   (with-host host
diff --git a/core/spec.lisp b/core/spec.lisp
index 7782432..632b992 100644
--- a/core/spec.lisp
+++ b/core/spec.lisp
@@ -117,31 +117,30 @@ Second value lists properties in line with spec. Format is
 
 (defmethod resource-diff ((res resource))
   (let ((specified-properties (specified-properties res))
-        ok diff)
+        diff)
     (loop
        (when (endp specified-properties)
          (return))
-       (let* ((sp (pop specified-properties))
-              (property (first sp))
-              (specified (second sp))
+       (let* ((property (pop specified-properties))
+              (specified (pop specified-properties))
               (probed (get-probed res property))
               (desc (describe-probed-property-value res property probed)))
-         (if (match-specified-value res property specified desc)
-             (push sp ok)
-             (push `(,property ,specified ,desc) diff))))
-    diff))
+         (unless (match-specified-value res property specified desc)
+           (push `(,property ,specified ,desc) diff))))
+    (nreverse diff)))
 
 #+nil
 (resource-diff (resource 'directory "/" :owner "root" :uid 0))
 
 (defmethod resource-diff ((res resource-container))
-  (let ((diffs))
-    (do-resources (r) res
-      (let ((d (resource-diff r)))
-        (when d
-          (push (cons r d) diffs))))
-    (append (call-next-method res)
-            (sort diffs #'resource-before-p :key #'first))))
+  (with-parent-resource res
+    (let ((diffs))
+      (do-resources (r) res
+        (let ((d (resource-diff r)))
+          (when d
+            (push (cons r d) diffs))))
+      (append (call-next-method res)
+              (sort diffs #'resource-before-p :key #'first)))))
 
 (defmethod resource-diff ((host host))
   (with-host host